diff --git a/Gillian-C/lib/cParserAndCompiler.ml b/Gillian-C/lib/cParserAndCompiler.ml index 66cbdad77..6e5b5e2b6 100644 --- a/Gillian-C/lib/cParserAndCompiler.ml +++ b/Gillian-C/lib/cParserAndCompiler.ml @@ -243,11 +243,13 @@ let optimise_calls_in_proc proc genv = method! visit_cmd _ cmd = match cmd with | Call - ( x, - Lit (String fname), - [ EList [ Lit (Loc l); Lit (Int z) ] ], - None, - None ) + { + var_name = x; + fct_name = Lit (String fname); + args = [ EList [ Lit (Loc l); Lit (Int z) ] ]; + bindings = None; + err_lab = None; + } when fname = Internal_Functions.get_function_name && Z.(equal z zero) -> ( match get_fname l with @@ -419,8 +421,8 @@ let parse_and_compile_files paths = List.sort_uniq (fun a b -> match (a, b) with - | ( Cmd.Call (_, _, Lit (Loc a) :: _, _, _), - Cmd.Call (_, _, Lit (Loc b) :: _, _, _) ) -> String.compare a b + | ( Cmd.Call { args = Lit (Loc a) :: _; _ }, + Cmd.Call { args = Lit (Loc b) :: _; _ } ) -> String.compare a b | _ -> failwith "Wrong init cmd") (init_cmds @ genv_init_cmds) in diff --git a/Gillian-C/lib/gilgen.ml b/Gillian-C/lib/gilgen.ml index fae4d0c77..a6b32ad99 100644 --- a/Gillian-C/lib/gilgen.ml +++ b/Gillian-C/lib/gilgen.ml @@ -62,7 +62,7 @@ let trans_binop_expr ~fname binop te1 te2 = let call func = let gvar = Generators.gen_str ~fname Prefix.gvar in ( [ - Cmd.Call (gvar, Expr.Lit (Literal.String func), [ te1; te2 ], None, None); + Cmd.call (gvar, Expr.Lit (Literal.String func), [ te1; te2 ], None, None); ], Expr.PVar gvar ) in @@ -143,14 +143,14 @@ let rec trans_expr ~fname ~local_env expr = let gvar = gen_str Prefix.gvar in let loadv = Expr.Lit (Literal.String Internal_Functions.loadv) in let cmd = - Cmd.Call (gvar, loadv, [ expr_of_chunk chunk; e ], None, None) + Cmd.call (gvar, loadv, [ expr_of_chunk chunk; e ], None, None) in (cl @ [ cmd ], Expr.PVar gvar) | Eunop (uop, e) -> let cl, e = trans_expr e in let gvar = gen_str Prefix.gvar in let ip = internal_proc_of_unop uop in - let call = Cmd.Call (gvar, Lit (Literal.String ip), [ e ], None, None) in + let call = Cmd.call (gvar, Lit (Literal.String ip), [ e ], None, None) in (cl @ [ call ], PVar gvar) | Ebinop (binop, e1, e2) -> let leading_e1, te1 = trans_expr e1 in @@ -205,7 +205,7 @@ let make_free_cmd fname var_list = match make_blocks var_list with | [] -> None | blocks -> - Some (Cmd.Call (gvar, freelist, [ Expr.EList blocks ], None, None)) + Some (Cmd.call (gvar, freelist, [ Expr.EList blocks ], None, None)) let make_symb_gen ~fname ~ctx assigned_id type_string = let gen_str = Generators.gen_str ~fname in @@ -273,7 +273,7 @@ let rec trans_stmt ~fname ~context stmt = Expr.Lit (Literal.String Internal_Functions.bool_of_val) in let texb = gen_str Prefix.gvar in - let bov = Cmd.Call (texb, bool_of_val, [ texp ], None, None) in + let bov = Cmd.call (texb, bool_of_val, [ texp ], None, None) in let a_bov = (annot_ctx context, None, bov) in let guard = Cmd.GuardedGoto (PVar texb, then_lab, else_lab) in let goto_end = Cmd.Goto endif_lab in @@ -348,7 +348,7 @@ let rec trans_stmt ~fname ~context stmt = let storev = Expr.Lit (Literal.String Internal_Functions.storev) in let gvar = gen_str Prefix.gvar in let cmd = - Cmd.Call (gvar, storev, [ chunk_expr; eaddr; ev ], None, None) + Cmd.call (gvar, storev, [ chunk_expr; eaddr; ev ], None, None) in annot_addr_eval @ annot_v_eval @ [ (annot_ctx context, None, cmd) ] | Scall (None, _, ex, [ e ]) when is_assert_call ex -> @@ -391,10 +391,10 @@ let rec trans_stmt ~fname ~context stmt = Expr.Lit (Literal.String Internal_Functions.get_function_name) in let get_fname = - Cmd.Call (fname_var, s_get_function_name, [ fn_expr ], None, None) + Cmd.call (fname_var, s_get_function_name, [ fn_expr ], None, None) in let call_cmd = - Cmd.Call (leftvar, Expr.PVar fname_var, trans_params, None, None) + Cmd.call (leftvar, Expr.PVar fname_var, trans_params, None, None) in add_annots ~ctx:context leading_fn @ add_annots ~ctx:context leading_params @@ -532,7 +532,7 @@ let rec trans_stmt ~fname ~context stmt = let cmds_src, src = trans_expr src in let temp = gen_str Prefix.gvar in let call = - Cmd.Call + Cmd.call ( temp, Expr.string Internal_Functions.ef_memcpy, [ Expr.int_z sz; Expr.int_z al; dst; src ], @@ -593,7 +593,7 @@ let trans_function let expr_fn = Expr.Lit (Literal.String CConstants.Internal_Functions.initialize_genv) in - [ (empty_annot, None, Cmd.Call (gvar, expr_fn, [], None, None)) ] + [ (empty_annot, None, Cmd.call (gvar, expr_fn, [], None, None)) ] else [] in let body = trans_stmt ~fname ~context fn_body in @@ -639,9 +639,9 @@ let set_global_var symbol v = in let id_list_expr = Expr.Lit (Literal.LList init_data_list) in let setvar = CConstants.Internal_Functions.glob_set_var in - Cmd.Call + Cmd.call ( "u", - Lit (String setvar), + Expr.Lit (String setvar), [ loc; sz; id_list_expr; perm_string ], None, None ) diff --git a/Gillian-JS/lib/Compiler/JSIL2GIL.ml b/Gillian-JS/lib/Compiler/JSIL2GIL.ml index 97c09d171..075c09994 100644 --- a/Gillian-JS/lib/Compiler/JSIL2GIL.ml +++ b/Gillian-JS/lib/Compiler/JSIL2GIL.ml @@ -461,7 +461,7 @@ let jsil2core (lab : string option) (cmd : LabCmd.t) : | LGoto j -> [ (lab, GCmd.Goto j) ] | LGuardedGoto (e, j, k) -> [ (lab, GCmd.GuardedGoto (fe e, j, k)) ] | LCall (x, e, es, j, subst) -> - [ (lab, GCmd.Call (x, fe e, List.map fe es, j, subst)) ] + [ (lab, GCmd.call (x, fe e, List.map fe es, j, subst)) ] | LECall (x, e, es, j) -> [ (lab, GCmd.ECall (x, fe e, List.map fe es, j)) ] | LApply (x, e, j) -> [ (lab, GCmd.Apply (x, fe e, j)) ] | LArguments x -> [ (lab, GCmd.Arguments x) ] diff --git a/GillianCore/GIL_Syntax/Cmd.ml b/GillianCore/GIL_Syntax/Cmd.ml index 570e79609..546062f88 100644 --- a/GillianCore/GIL_Syntax/Cmd.ml +++ b/GillianCore/GIL_Syntax/Cmd.ml @@ -9,6 +9,15 @@ module SS = Containers.SS type logic_bindings_t = string * (string * Expr.t) list [@@deriving yojson] +type 'label function_call = 'label TypeDef__.function_call = { + var_name : string; + fct_name : Expr.t; + args : Expr.t list; + err_lab : 'label option; + bindings : logic_bindings_t option; +} +[@@deriving yojson] + type 'label t = 'label TypeDef__.cmd = | Skip (** Skip *) | Assignment of string * Expr.t (** Assignment *) @@ -16,11 +25,10 @@ type 'label t = 'label TypeDef__.cmd = | Logic of LCmd.t (** GIL Logic commands *) | Goto of 'label (** Unconditional goto *) | GuardedGoto of Expr.t * 'label * 'label (** Conditional goto *) - | Call of - string * Expr.t * Expr.t list * 'label option * logic_bindings_t option - (** Procedure call *) + | Call of 'label function_call (** Procedure call *) | ECall of string * Expr.t * Expr.t list * 'label option (** External Procedure call *) + | Par of 'label function_call list (** Parallel composition *) | Apply of string * Expr.t * 'label option (** Application-style procedure call *) | Arguments of string (** Arguments of the current function *) @@ -34,6 +42,9 @@ let fold = List.fold_left SS.union SS.empty let pvars (cmd : 'label t) : SS.t = let pvars_es es = fold (List.map Expr.pvars es) in + let pvars_fcall { var_name = x; fct_name = e; args = es; _ } = + SS.union (SS.add x (Expr.pvars e)) (pvars_es es) + in match cmd with | Skip -> SS.empty | Assignment (x, e) -> SS.add x (Expr.pvars e) @@ -41,7 +52,11 @@ let pvars (cmd : 'label t) : SS.t = | Logic lcmd -> LCmd.pvars lcmd | Goto _ -> SS.empty | GuardedGoto (e, _, _) -> Expr.pvars e - | Call (x, e, es, _, _) -> SS.union (SS.add x (Expr.pvars e)) (pvars_es es) + | Par fcalls -> + List.fold_left + (fun acc f -> pvars_fcall f |> SS.union acc) + SS.empty fcalls + | Call fcall -> pvars_fcall fcall | ECall (x, e, es, _) -> SS.union (SS.add x (Expr.pvars e)) (pvars_es es) | Apply (x, e, _) -> SS.add x (Expr.pvars e) | Arguments x -> SS.singleton x @@ -51,6 +66,9 @@ let pvars (cmd : 'label t) : SS.t = let lvars (cmd : 'label t) : SS.t = let lvars_es es = fold (List.map Expr.lvars es) in + let lvars_fcall { fct_name = e; args = es; _ } = + SS.union (Expr.lvars e) (lvars_es es) + in match cmd with | Skip -> SS.empty | Assignment (_, e) -> Expr.lvars e @@ -58,7 +76,11 @@ let lvars (cmd : 'label t) : SS.t = | Logic lcmd -> LCmd.lvars lcmd | Goto _ -> SS.empty | GuardedGoto (e, _, _) -> Expr.lvars e - | Call (_, e, es, _, _) -> SS.union (Expr.lvars e) (lvars_es es) + | Par fcalls -> + List.fold_left + (fun acc f -> lvars_fcall f |> SS.union acc) + SS.empty fcalls + | Call fcall -> lvars_fcall fcall | ECall (_, e, es, _) -> SS.union (Expr.lvars e) (lvars_es es) | Apply (_, e, _) -> Expr.lvars e | Arguments _ -> SS.empty @@ -68,6 +90,9 @@ let lvars (cmd : 'label t) : SS.t = let locs (cmd : 'label t) : SS.t = let locs_es es = fold (List.map Expr.locs es) in + let locs_fcall { fct_name = e; args = es; _ } = + SS.union (Expr.lvars e) (locs_es es) + in match cmd with | Skip -> SS.empty | Assignment (_, e) -> Expr.locs e @@ -75,7 +100,9 @@ let locs (cmd : 'label t) : SS.t = | Logic lcmd -> LCmd.lvars lcmd | Goto _ -> SS.empty | GuardedGoto (e, _, _) -> Expr.locs e - | Call (_, e, es, _, _) -> SS.union (Expr.lvars e) (locs_es es) + | Par fcalls -> + List.fold_left (fun acc f -> locs_fcall f |> SS.union acc) SS.empty fcalls + | Call fcall -> locs_fcall fcall | ECall (_, e, es, _) -> SS.union (Expr.lvars e) (locs_es es) | Apply (_, e, _) -> Expr.locs e | Arguments _ -> SS.empty @@ -87,10 +114,15 @@ let successors (cmd : int t) (i : int) : int list = match cmd with | Goto j -> [ j ] | GuardedGoto (_, j, k) -> [ j; k ] - | Call (_, _, _, j, _) | ECall (_, _, _, j) | Apply (_, _, j) -> ( - match j with - | None -> [ i + 1 ] - | Some j -> [ i + 1; j ]) + | Par [] -> failwith "Encountered a par constructor with no function calls!" + | Par fcalls -> + if List.exists (fun f -> Option.is_some f.err_lab) fcalls then + failwith + "Invalid GIL program: parallel calls may not have error labels!"; + [ i + 1 ] + (* We want to resume execution one label past the last function call *) + | Call { err_lab; _ } | ECall (_, _, _, err_lab) | Apply (_, _, err_lab) -> + (i + 1) :: Option.to_list err_lab | ReturnNormal | ReturnError | Fail _ -> [] | Skip | Assignment _ | LAction _ | Logic _ | Arguments _ | PhiAssignment _ -> [ i + 1 ] @@ -110,7 +142,12 @@ let pp_logic_bindings = (** GIL All Statements *) let pp ~(pp_label : 'a Fmt.t) fmt (cmd : 'a t) = let pp_params = Fmt.list ~sep:Fmt.comma Expr.pp in - let pp_error f er = Fmt.pf f " with %a" pp_label er in + let pp_error fmt er = Fmt.pf fmt " with %a" pp_label er in + let pp_fcall fmt { var_name; fct_name; args; err_lab; bindings } = + let pp_subst fmt lbs = Fmt.pf fmt " use_subst %a" pp_logic_bindings lbs in + Fmt.pf fmt "%s := %a(@[%a@])%a%a" var_name Expr.pp fct_name pp_params args + (Fmt.option pp_error) err_lab (Fmt.option pp_subst) bindings + in match cmd with | Skip -> Fmt.string fmt "skip" | Assignment (x, e) -> Fmt.pf fmt "%s := @[%a@]" x Expr.pp e @@ -118,10 +155,8 @@ let pp ~(pp_label : 'a Fmt.t) fmt (cmd : 'a t) = | Goto j -> Fmt.pf fmt "goto %a" pp_label j | GuardedGoto (e, j, k) -> Fmt.pf fmt "@[goto [%a] %a %a@]" Expr.pp e pp_label j pp_label k - | Call (var, name, args, error, subst) -> - let pp_subst f lbs = Fmt.pf f " use_subst %a" pp_logic_bindings lbs in - Fmt.pf fmt "%s := %a(@[%a@])%a%a" var Expr.pp name pp_params args - (Fmt.option pp_error) error (Fmt.option pp_subst) subst + | Par fs -> Fmt.pf fmt "@[par [%a]@]" Fmt.(list ~sep:semi pp_fcall) fs + | Call fcall -> pp_fcall fmt fcall | ECall (var, name, args, error) -> Fmt.pf fmt "%s := extern %a(@[%a@])%a" var Expr.pp name pp_params args (Fmt.option pp_error) error @@ -142,3 +177,7 @@ let pp ~(pp_label : 'a Fmt.t) fmt (cmd : 'a t) = let pp_labeled = pp ~pp_label:Fmt.string let pp_indexed = pp ~pp_label:Fmt.int + +(* Legacy interface to simplify migration *) +let call (var_name, fct_name, args, err_lab, bindings) = + Call { var_name; fct_name; args; err_lab; bindings } diff --git a/GillianCore/GIL_Syntax/Formula.ml b/GillianCore/GIL_Syntax/Formula.ml index 79147937e..254ba3037 100644 --- a/GillianCore/GIL_Syntax/Formula.ml +++ b/GillianCore/GIL_Syntax/Formula.ml @@ -408,12 +408,12 @@ module Infix = struct let ( #>. ) a b = match (a, b) with | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x > y) - | _ -> fnot a #<= b + | _ -> fnot a#<=.b let ( #>=. ) a b = match (a, b) with | Expr.Lit (Num x), Expr.Lit (Num y) -> of_bool (x >= y) - | _ -> fnot a #< b + | _ -> fnot a#<.b let ( #=> ) fa fb = (fnot fa) #|| fb end diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index e405b9a2a..586ea8175 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -713,6 +713,14 @@ module Cmd : sig (** Optional bindings for procedure calls *) type logic_bindings_t = string * (string * Expr.t) list + type 'label function_call = { + var_name : string; + fct_name : Expr.t; + args : Expr.t list; + err_lab : 'label option; + bindings : logic_bindings_t option; + } + type 'label t = | Skip (** Skip *) | Assignment of string * Expr.t (** Variable Assignment *) @@ -720,11 +728,10 @@ module Cmd : sig | Logic of LCmd.t (** Logic commands *) | Goto of 'label (** Unconditional goto *) | GuardedGoto of Expr.t * 'label * 'label (** Conditional goto *) - | Call of - string * Expr.t * Expr.t list * 'label option * logic_bindings_t option - (** Procedure call *) + | Call of 'label function_call (** Procedure call *) | ECall of string * Expr.t * Expr.t list * 'label option (** External Procedure call *) + | Par of 'label function_call list (** Parallel procedure calls *) | Apply of string * Expr.t * 'label option (** Application-style procedure call *) | Arguments of string (** Arguments of the currently executing function *) @@ -734,6 +741,13 @@ module Cmd : sig | Fail of string * Expr.t list (** Failure *) [@@deriving yojson] + (** Legacy interface to simplify migration to the new call definition as a record *) + val call : + string * Expr.t * Expr.t list * 'label option * logic_bindings_t option -> + 'label t + + (** @deprecated Use {!Visitors.endo} instead *) + (** Pretty-printer *) val pp : pp_label:'a Fmt.t -> Format.formatter -> 'a t -> unit @@ -1271,15 +1285,7 @@ module Visitors : sig ; visit_Bool : 'c -> Literal.t -> bool -> Literal.t ; visit_BooleanType : 'c -> Type.t -> Type.t ; visit_Branch : 'c -> LCmd.t -> Formula.t -> LCmd.t - ; visit_Call : - 'c -> - 'f Cmd.t -> - string -> - Expr.t -> - Expr.t list -> - 'f option -> - (string * (string * Expr.t) list) option -> - 'f Cmd.t + ; visit_Call : 'c -> 'f Cmd.t -> 'f Cmd.function_call -> 'f Cmd.t ; visit_Car : 'c -> UnOp.t -> UnOp.t ; visit_Cdr : 'c -> UnOp.t -> UnOp.t ; visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t @@ -1291,6 +1297,7 @@ module Visitors : sig Expr.t list -> 'f option -> 'f Cmd.t + ; visit_Par : 'c -> 'f Cmd.t -> 'f Cmd.function_call list -> 'f Cmd.t ; visit_EList : 'c -> Expr.t -> Expr.t list -> Expr.t ; visit_ESet : 'c -> Expr.t -> Expr.t list -> Expr.t ; visit_Emp : 'c -> Asrt.t -> Asrt.t @@ -1464,6 +1471,8 @@ module Visitors : sig string * (string * Expr.t) list ; visit_binop : 'c -> BinOp.t -> BinOp.t ; visit_bispec : 'c -> BiSpec.t -> BiSpec.t + ; visit_function_call : + 'c -> 'f Cmd.function_call -> 'f Cmd.function_call ; visit_cmd : 'c -> 'f Cmd.t -> 'f Cmd.t ; visit_constant : 'c -> Constant.t -> Constant.t ; visit_expr : 'c -> Expr.t -> Expr.t @@ -1518,17 +1527,7 @@ module Visitors : sig method visit_Bool : 'c -> Literal.t -> bool -> Literal.t method visit_BooleanType : 'c -> Type.t -> Type.t method visit_Branch : 'c -> LCmd.t -> Formula.t -> LCmd.t - - method visit_Call : - 'c -> - 'f Cmd.t -> - string -> - Expr.t -> - Expr.t list -> - 'f option -> - (string * (string * Expr.t) list) option -> - 'f Cmd.t - + method visit_Call : 'c -> 'f Cmd.t -> 'f Cmd.function_call -> 'f Cmd.t method visit_Car : 'c -> UnOp.t -> UnOp.t method visit_Cdr : 'c -> UnOp.t -> UnOp.t method visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t @@ -1542,6 +1541,7 @@ module Visitors : sig 'f option -> 'f Cmd.t + method visit_Par : 'c -> 'f Cmd.t -> 'f Cmd.function_call list -> 'f Cmd.t method visit_EList : 'c -> Expr.t -> Expr.t list -> Expr.t method visit_ESet : 'c -> Expr.t -> Expr.t list -> Expr.t method visit_Emp : 'c -> Asrt.t -> Asrt.t @@ -1736,6 +1736,10 @@ module Visitors : sig method private visit_bool : 'env. 'env -> bool -> bool method private visit_bytes : 'env. 'env -> bytes -> bytes method private visit_char : 'env. 'env -> char -> char + + method visit_function_call : + 'c -> 'f Cmd.function_call -> 'f Cmd.function_call + method visit_cmd : 'c -> 'f Cmd.t -> 'f Cmd.t method visit_constant : 'c -> Constant.t -> Constant.t method visit_expr : 'c -> Expr.t -> Expr.t @@ -1819,14 +1823,7 @@ module Visitors : sig ; visit_Bool : 'c -> bool -> 'f ; visit_BooleanType : 'c -> 'f ; visit_Branch : 'c -> Formula.t -> 'f - ; visit_Call : - 'c -> - string -> - Expr.t -> - Expr.t list -> - 'g option -> - (string * (string * Expr.t) list) option -> - 'f + ; visit_Call : 'c -> 'g Cmd.function_call -> 'f ; visit_Car : 'c -> 'f ; visit_Cdr : 'c -> 'f ; visit_Constant : 'c -> Constant.t -> 'f @@ -1834,6 +1831,7 @@ module Visitors : sig ; visit_FDiv : 'c -> 'f ; visit_ECall : 'c -> string -> Expr.t -> Expr.t list -> 'g option -> 'f + ; visit_Par : 'c -> 'g Cmd.function_call list -> 'f ; visit_EList : 'c -> Expr.t list -> 'f ; visit_ESet : 'c -> Expr.t list -> 'f ; visit_Emp : 'c -> 'f @@ -1991,6 +1989,7 @@ module Visitors : sig ; visit_bindings : 'c -> string * (string * Expr.t) list -> 'f ; visit_binop : 'c -> BinOp.t -> 'f ; visit_bispec : 'c -> BiSpec.t -> 'f + ; visit_function_call : 'c -> 'g Cmd.function_call -> 'f ; visit_cmd : 'c -> 'g Cmd.t -> 'f ; visit_constant : 'c -> Constant.t -> 'f ; visit_expr : 'c -> Expr.t -> 'f @@ -2041,16 +2040,7 @@ module Visitors : sig method visit_Bool : 'c -> bool -> 'f method visit_BooleanType : 'c -> 'f method visit_Branch : 'c -> Formula.t -> 'f - - method visit_Call : - 'c -> - string -> - Expr.t -> - Expr.t list -> - 'g option -> - (string * (string * Expr.t) list) option -> - 'f - + method visit_Call : 'c -> 'g Cmd.function_call -> 'f method visit_Car : 'c -> 'f method visit_Cdr : 'c -> 'f method visit_Constant : 'c -> Constant.t -> 'f @@ -2060,6 +2050,7 @@ module Visitors : sig method visit_ECall : 'c -> string -> Expr.t -> Expr.t list -> 'g option -> 'f + method visit_Par : 'c -> 'g Cmd.function_call list -> 'f method visit_EList : 'c -> Expr.t list -> 'f method visit_ESet : 'c -> Expr.t list -> 'f method visit_Emp : 'c -> 'f @@ -2222,6 +2213,7 @@ module Visitors : sig method visit_bindings : 'c -> string * (string * Expr.t) list -> 'f method visit_binop : 'c -> BinOp.t -> 'f method visit_bispec : 'c -> BiSpec.t -> 'f + method visit_function_call : 'c -> 'g Cmd.function_call -> 'f method visit_cmd : 'c -> 'g Cmd.t -> 'f method visit_constant : 'c -> Constant.t -> 'f method visit_expr : 'c -> Expr.t -> 'f @@ -2275,19 +2267,13 @@ module Visitors : sig ; visit_Bool : 'c -> bool -> unit ; visit_BooleanType : 'c -> unit ; visit_Branch : 'c -> Formula.t -> unit - ; visit_Call : - 'c -> - string -> - Expr.t -> - Expr.t list -> - 'f option -> - Cmd.logic_bindings_t option -> - unit + ; visit_Call : 'c -> 'f Cmd.function_call -> unit ; visit_Car : 'c -> unit ; visit_Cdr : 'c -> unit ; visit_Constant : 'c -> Constant.t -> unit ; visit_ECall : 'c -> string -> Expr.t -> Expr.t list -> 'f option -> unit + ; visit_Par : 'c -> 'f Cmd.function_call list -> unit ; visit_EList : 'c -> Expr.t list -> unit ; visit_ESet : 'c -> Expr.t list -> unit ; visit_Emp : 'c -> unit @@ -2447,6 +2433,7 @@ module Visitors : sig ; visit_bindings : 'c -> string * (string * Expr.t) list -> unit ; visit_binop : 'c -> BinOp.t -> unit ; visit_bispec : 'c -> BiSpec.t -> unit + ; visit_function_call : 'c -> 'f Cmd.function_call -> unit ; visit_cmd : 'c -> 'f Cmd.t -> unit ; visit_constant : 'c -> Constant.t -> unit ; visit_expr : 'c -> Expr.t -> unit @@ -2496,16 +2483,7 @@ module Visitors : sig method visit_Bool : 'c -> bool -> unit method visit_BooleanType : 'c -> unit method visit_Branch : 'c -> Formula.t -> unit - - method visit_Call : - 'c -> - string -> - Expr.t -> - Expr.t list -> - 'f option -> - (string * (string * Expr.t) list) option -> - unit - + method visit_Call : 'c -> 'f Cmd.function_call -> unit method visit_Car : 'c -> unit method visit_Cdr : 'c -> unit method visit_Constant : 'c -> Constant.t -> unit @@ -2513,6 +2491,7 @@ module Visitors : sig method visit_ECall : 'c -> string -> Expr.t -> Expr.t list -> 'f option -> unit + method visit_Par : 'c -> 'f Cmd.function_call list -> unit method visit_EList : 'c -> Expr.t list -> unit method visit_ESet : 'c -> Expr.t list -> unit method visit_Emp : 'c -> unit @@ -2684,6 +2663,7 @@ module Visitors : sig method private visit_bool : 'env. 'env -> bool -> unit method private visit_bytes : 'env. 'env -> bytes -> unit method private visit_char : 'env. 'env -> char -> unit + method visit_function_call : 'c -> 'f Cmd.function_call -> unit method visit_cmd : 'c -> 'f Cmd.t -> unit method visit_constant : 'c -> Constant.t -> unit method visit_expr : 'c -> Expr.t -> unit diff --git a/GillianCore/GIL_Syntax/Proc.ml b/GillianCore/GIL_Syntax/Proc.ml index 3f76e2fe8..e23bed8ba 100644 --- a/GillianCore/GIL_Syntax/Proc.ml +++ b/GillianCore/GIL_Syntax/Proc.ml @@ -103,49 +103,46 @@ let indexed_of_labeled (lproc : ('annot, string) t) : ('annot, int) t = in let cmds = Array.map - (function - | spec, l, labeled_cmd -> - let indexed_cmd : int Cmd.t = - match (labeled_cmd : string Cmd.t) with - | Skip -> Cmd.Skip - | Assignment (x, e) -> Cmd.Assignment (x, e) - | LAction (x, la_name, es) -> Cmd.LAction (x, la_name, es) - | Goto lab -> Cmd.Goto (find_with_error mapping lab) - | GuardedGoto (e, lt, lf) -> - Cmd.GuardedGoto - (e, find_with_error mapping lt, find_with_error mapping lf) - | Call (x, e, le, ol, subst) -> - Cmd.Call - ( x, - e, - le, - (match ol with - | None -> None - | Some lab -> Some (find_with_error mapping lab)), - subst ) - | ECall (x, e, le, ol) -> - Cmd.ECall - ( x, - e, - le, - match ol with - | None -> None - | Some lab -> Some (find_with_error mapping lab) ) - | Apply (x, le, ol) -> - Cmd.Apply - ( x, - le, - match ol with - | None -> None - | Some lab -> Some (find_with_error mapping lab) ) - | Arguments var -> Cmd.Arguments var - | PhiAssignment xargs -> Cmd.PhiAssignment xargs - | ReturnNormal -> Cmd.ReturnNormal - | ReturnError -> Cmd.ReturnError - | Fail (et, es) -> Cmd.Fail (et, es) - | Logic lcmd -> Cmd.Logic lcmd - in - (spec, l, indexed_cmd)) + (fun (spec, l, labeled_cmd) -> + let indexed_fcall (fcall : string Cmd.function_call) : + int Cmd.function_call = + let Cmd.{ var_name; fct_name; args; err_lab; bindings } = fcall in + { + var_name; + fct_name; + args; + err_lab = Option.map (find_with_error mapping) err_lab; + bindings; + } + in + let indexed_cmd (cmd : string Cmd.t) : int Cmd.t = + match (cmd : string Cmd.t) with + | Skip -> Cmd.Skip + | Assignment (x, e) -> Cmd.Assignment (x, e) + | LAction (x, la_name, es) -> Cmd.LAction (x, la_name, es) + | Goto lab -> Cmd.Goto (find_with_error mapping lab) + | GuardedGoto (e, lt, lf) -> + Cmd.GuardedGoto + (e, find_with_error mapping lt, find_with_error mapping lf) + | Par fs -> Cmd.Par (List.map indexed_fcall fs) + | Call fcall -> Cmd.Call (indexed_fcall fcall) + | ECall (x, e, le, ol) -> + Cmd.ECall (x, e, le, Option.map (find_with_error mapping) ol) + | Apply (x, le, ol) -> + Cmd.Apply + ( x, + le, + match ol with + | None -> None + | Some lab -> Some (find_with_error mapping lab) ) + | Arguments var -> Cmd.Arguments var + | PhiAssignment xargs -> Cmd.PhiAssignment xargs + | ReturnNormal -> Cmd.ReturnNormal + | ReturnError -> Cmd.ReturnError + | Fail (et, es) -> Cmd.Fail (et, es) + | Logic lcmd -> Cmd.Logic lcmd + in + (spec, l, indexed_cmd labeled_cmd)) cmds_nolab in cmds diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index d7f3147fb..ff6642a31 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -186,6 +186,14 @@ and lcmd = | FreshSVar of string | SL of slcmd +and 'label function_call = { + var_name : string; + fct_name : expr; + args : expr list; + err_lab : 'label option; + bindings : bindings option; +} + and 'label cmd = | Skip | Assignment of string * expr @@ -193,8 +201,9 @@ and 'label cmd = | Logic of lcmd | Goto of 'label | GuardedGoto of expr * 'label * 'label - | Call of string * expr * expr list * 'label option * bindings option + | Call of 'label function_call | ECall of string * expr * expr list * 'label option + | Par of 'label function_call list | Apply of string * expr * 'label option | Arguments of string | PhiAssignment of (string * expr list) list diff --git a/GillianCore/engine/Abstraction/PState.ml b/GillianCore/engine/Abstraction/PState.ml index 09d096a94..396aa124d 100644 --- a/GillianCore/engine/Abstraction/PState.ml +++ b/GillianCore/engine/Abstraction/PState.ml @@ -310,6 +310,114 @@ module Make let state' = set_store state store in state' + let rec run_par_spec_aux fcs astate = + match fcs with + | [] -> Ok [] + | (existential_bindings, name, params, up, x, args) :: rest -> ( + L.verbose (fun m -> + m "INSIDE RUN spec of %s with the following UP:@\n%a@\n" name UP.pp + up); + + let old_store = get_store astate in + let new_store = + try Store.init (List.combine params args) + with Invalid_argument _ -> + let message = + Fmt.str + "Running spec of %s which takes %i parameters with the \ + following %i arguments : %a" + name (List.length params) (List.length args) + (Fmt.Dump.list Val.pp) args + in + raise (Invalid_argument message) + in + let astate' = set_store astate new_store in + let existential_bindings = + Option.value ~default:[] existential_bindings + in + let existential_bindings = + List.map (fun (x, v) -> (Expr.LVar x, v)) existential_bindings + in + let store_bindings = Store.bindings new_store in + let store_bindings = + List.map (fun (x, v) -> (Expr.PVar x, v)) store_bindings + in + let subst = ESubst.init (existential_bindings @ store_bindings) in + + L.verbose (fun m -> + m "About to use the spec of %s with the following UP:@\n%a@\n" name + UP.pp up); + match SUnifier.unify astate' subst up FunctionCall with + | Ok rets -> + let open Syntaxes.Result in + let ( let++ ) x f = List.concat_map f x in + let lambda acc (frame_state, subst, posts) = + let* acc = acc in + let frame_state = set_store frame_state (Store.copy old_store) in + let* rets = run_par_spec_aux rest frame_state in + let frames = + match rets with + | [] -> [ frame_state ] + | l -> List.map fst l + in + L.verbose (fun m -> + m "Returned from recursive call with length %s" + (string_of_int @@ List.length rets)); + let fl, posts = + match posts with + | Some (fl, posts) -> (fl, posts) + | _ -> + let msg = + Printf.sprintf + "SYNTAX ERROR: Spec of %s does not have a postcondition" + name + in + L.normal (fun m -> m "%s" msg); + raise (Failure msg) + in + (* OK FOR DELAY ENTAILMENT *) + let res = + let++ frame_state = frames in + let frame_store = get_store frame_state in + let frame_state = + set_store frame_state (Store.copy new_store) + in + let++ final_state = + SUnifier.produce_posts frame_state subst posts + in + let final_store = get_store final_state in + let v_ret = Store.get final_store Names.return_variable in + let final_state = + set_store final_state (Store.copy frame_store) + in + let v_ret = + Option.value + ~default:(Option.get (Val.from_expr (Lit Undefined))) + v_ret + in + let final_state = update_store final_state x v_ret in + let _, final_states = simplify ~unification:true final_state in + List.map + (fun final_state -> + ( snd + (Option.get + (SUnifier.unfold_concrete_preds final_state)), + fl )) + final_states + in + Ok (acc @ res) + in + List.fold_left lambda (Ok []) rets + | Error errs -> + let msg = + Fmt.str + "WARNING: Failed to unify against the precondition of \ + procedure %s" + name + in + L.normal (fun m -> m "%s" msg); + Error errs) + (* FIXME: This needs to change -> we need to return a unification ret type, so we can compose with bi-abduction at the spec level *) let run_spec_aux @@ -1093,6 +1201,28 @@ module Make run_spec_aux ~existential_bindings:subst_lst spec.data.spec_name spec.data.spec_params spec.up astate (Some x) args + let run_par_spec + (fcs : + (UP.spec * string * vt list * (string * (string * vt) list) option) list) + (astate : t) : ((t * Flag.t) list, err_t list) result = + let fcs = + List.map + (fun ((spec : UP.spec), x, args, subst) -> + let existential_bindings = + match subst with + | Some (_, subst_lst) -> Some subst_lst + | None -> None + in + ( existential_bindings, + spec.data.spec_name, + spec.data.spec_params, + spec.up, + Some x, + args )) + fcs + in + run_par_spec_aux fcs astate + let unify (astate : t) (subst : st) diff --git a/GillianCore/engine/BiAbduction/BiState.ml b/GillianCore/engine/BiAbduction/BiState.ml index eecbabd17..ebcc18745 100644 --- a/GillianCore/engine/BiAbduction/BiState.ml +++ b/GillianCore/engine/BiAbduction/BiState.ml @@ -468,6 +468,12 @@ struct (* update_statistics "run_spec" (time() -. start_time); *) Ok result + let run_par_spec + (_ : + (UP.spec * string * vt list * (string * (string * vt) list) option) list) + (_ : t) : ((t * Flag.t) list, err_t list) result = + raise (Failure "ERROR: run_par_spec called for bi-abduction") + let produce_posts (_ : t) (_ : st) (_ : Asrt.t list) : t list = raise (Failure "produce_posts from bi_state.") diff --git a/GillianCore/engine/concrete_semantics/CState.ml b/GillianCore/engine/concrete_semantics/CState.ml index 4fa950e41..74f3bef56 100644 --- a/GillianCore/engine/concrete_semantics/CState.ml +++ b/GillianCore/engine/concrete_semantics/CState.ml @@ -168,6 +168,12 @@ end = struct ((t * Flag.t) list, err_t list) result = raise (Failure "ERROR: run_spec called for non-abstract execution") + let run_par_spec + (_ : + (UP.spec * string * vt list * (string * (string * vt) list) option) list) + (_ : t) : ((t * Flag.t) list, err_t list) result = + raise (Failure "ERROR: run_par_spec called for non-abstract execution") + let unfolding_vals (_ : t) (_ : Formula.t list) : vt list = raise (Failure "ERROR: unfolding_vals called for non-abstract execution") diff --git a/GillianCore/engine/general_semantics/general/g_interpreter.ml b/GillianCore/engine/general_semantics/general/g_interpreter.ml index 57369117a..e67f3925b 100644 --- a/GillianCore/engine/general_semantics/general/g_interpreter.ml +++ b/GillianCore/engine/general_semantics/general/g_interpreter.ml @@ -835,6 +835,55 @@ struct }; ]) + let exec_par_with_spec fcs eval_state = + let { state; i; b_counter; cs; branch_path; _ } = eval_state in + let process_ret = process_ret "par" None eval_state in + let fcs = + List.map + (fun (spec, x, pid, args, subst) -> + let subst = eval_subst_list state subst in + L.verbose (fun fmt -> fmt "ABOUT TO USE THE SPEC OF %s" pid); + (spec, x, args, subst)) + fcs + in + let rets : ((State.t * Flag.t) list, state_err_t list) result = + State.run_par_spec fcs state + in + match rets with + | Ok rets -> ( + L.verbose (fun fmt -> + fmt "Run_par_spec returned %d Results" (List.length rets)); + let b_counter = + if List.length rets > 1 then b_counter + 1 else b_counter + in + match rets with + | (ret_state, fl) :: rest_rets -> + let others = + List.map + (fun (ret_state, fl) -> + process_ret false ret_state fl b_counter None) + rest_rets + in + process_ret true ret_state fl b_counter (Some others) + :: others + | _ -> + L.fail + (Format.asprintf + "ERROR: Unable to use specification of a function in \ + parallel composition")) + | Error errors -> + let errors = errors |> List.map (fun e -> Exec_err.ESt e) in + [ + CConf.ConfErr + { + callstack = cs; + proc_idx = i; + error_state = state; + errors; + branch_path; + }; + ] + let exec_without_spec pid symb_exec_proc eval_state = let { prog; @@ -910,9 +959,27 @@ struct < !Config.bi_no_spec_depth -> symb_exec_proc () *) | _ -> spec_exec_proc ()) | false -> spec_exec_proc () + + let par_f fcs eval_state = + let { prog; state; _ } = eval_state in + let fcs = + List.map + (fun (var_name, pid, v_args, bindings) -> + let pid = get_pid_or_error pid state in + let spec, params = get_spec_and_params prog pid state in + let args = build_args v_args params in + match spec with + | Some spec -> (spec, var_name, pid, args, bindings) + | None -> + failwith + "Found function without specification in a parallel call") + fcs + in + exec_par_with_spec fcs eval_state end let eval_proc_call = Eval_proc_call.f + let eval_par_proc_call = Eval_proc_call.par_f let split_results results = let oks, errs = @@ -1298,6 +1365,17 @@ struct let result = eval_proc_call x pid v_args j subst eval_state in result + let eval_par_call fcs eval_state = + let { eval_expr; _ } = eval_state in + let lambda Cmd.{ var_name; fct_name; args; bindings; _ } = + DL.log (fun m -> m "Call"); + let pid = eval_expr fct_name in + let v_args = List.map eval_expr args in + (var_name, pid, v_args, bindings) + in + let fcs = List.map lambda fcs in + eval_par_proc_call fcs eval_state + (* External function call *) let eval_ecall x (pid : Expr.t) args j eval_state = let { @@ -1512,8 +1590,10 @@ struct ~prev_idx:i ~loop_ids ~next_idx:j ~branch_count:b_counter (); ] | GuardedGoto (e, j, k) -> eval_guarded_goto e j k eval_state + | Par fcs -> eval_par_call fcs eval_state | PhiAssignment lxarr -> eval_phi_assignment lxarr eval_state - | Call (x, e, args, j, subst) -> eval_call x e args j subst eval_state + | Call { var_name; fct_name; args; err_lab; bindings } -> + eval_call var_name fct_name args err_lab bindings eval_state | ECall (x, pid, args, j) -> eval_ecall x pid args j eval_state | Apply (x, pid_args, j) -> eval_apply x pid_args j eval_state (* Arguments *) diff --git a/GillianCore/engine/general_semantics/state.ml b/GillianCore/engine/general_semantics/state.ml index 97dfcf8a6..51843814c 100644 --- a/GillianCore/engine/general_semantics/state.ml +++ b/GillianCore/engine/general_semantics/state.ml @@ -138,6 +138,11 @@ module type S = sig (string * (string * vt) list) option -> ((t * Flag.t) list, err_t list) result + val run_par_spec : + (UP.spec * string * vt list * (string * (string * vt) list) option) list -> + t -> + ((t * Flag.t) list, err_t list) result + val unfolding_vals : t -> Formula.t list -> vt list val try_recovering : t -> vt Recovery_tactic.t -> (t list, string) result val substitution_in_place : ?subst_all:bool -> st -> t -> t list diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index a61e7d8bd..30bdea342 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -266,7 +266,7 @@ module Make (SMemory : SMemory.S) : let _, _, pfs, gamma, _ = state in let ps = List.map - (Reduction.reduce_formula + (Reduction.reduce_formula ~unification ~time:("SState: assume_a: " ^ time) ~pfs ~gamma) ps @@ -533,6 +533,12 @@ module Make (SMemory : SMemory.S) : ((t * Flag.t) list, err_t list) result = raise (Failure "ERROR: run_spec called for non-abstract execution") + let run_par_spec + (_ : + (UP.spec * string * vt list * (string * (string * vt) list) option) list) + (_ : t) : ((t * Flag.t) list, err_t list) result = + raise (Failure "ERROR: run_par_spec called for non-abstract execution") + let unfolding_vals (_ : t) (fs : Formula.t list) : vt list = let lvars = SS.of_list diff --git a/GillianCore/gil_parser/GIL_Parser.mly b/GillianCore/gil_parser/GIL_Parser.mly index 28f9c0476..154223d85 100644 --- a/GillianCore/gil_parser/GIL_Parser.mly +++ b/GillianCore/gil_parser/GIL_Parser.mly @@ -583,10 +583,9 @@ gcmd_target: | GOTO LBRACKET; e=expr_target; RBRACKET; i=VAR; j=VAR { Cmd.GuardedGoto (e, i, j) } (* x := e(e1, ..., en) with j use_subst [bla - #x: bla, #y: ble] *) - | v=VAR; DEFEQ; e=expr_target; - LBRACE; es=separated_list(COMMA, expr_target); RBRACE; oi = option(call_with_target); subst = option(use_subst_target) + | f=function_call { - Cmd.Call (v, e, es, oi, subst) + Cmd.Call f } (* x := e(e1, ..., en) with j *) | v=VAR; DEFEQ; EXTERN; pname=VAR; @@ -619,6 +618,13 @@ gcmd_target: ; +function_call: + var_name=VAR; DEFEQ; fct_name=expr_target; + LBRACE; args=separated_list(COMMA, expr_target); RBRACE; err_lab = option(call_with_target); bindings = option(use_subst_target) + { + Cmd.{ var_name; fct_name; args; err_lab; bindings } + } + g_only_spec_target: (* only *) AXIOMATIC; spec = g_spec_target diff --git a/dune b/dune index da27916bd..7d3085bde 100644 --- a/dune +++ b/dune @@ -1,5 +1,6 @@ (dirs wisl + wislfp GillianCore Gillian-Rely-Runner Gillian-JS diff --git a/esy.json b/esy.json index 32f179028..6a6a9d6c7 100644 --- a/esy.json +++ b/esy.json @@ -15,13 +15,15 @@ "esy-installer gillian.install", "esy-installer gillian-js.install", "esy-installer gillian-c.install", - "esy-installer wisl.install" + "esy-installer wisl.install", + "esy-installer wislfp.install" ], "release": { "bin": [ "gillian-js", "gillian-c", - "wisl" + "wisl", + "wislfp" ], "includePackages": [ "root", @@ -39,6 +41,10 @@ "val": "#{self.share}/wisl", "scope": "global" }, + "WISLFP_RUNTIME_PATH": { + "val": "#{self.share}/wislfp", + "scope": "global" + }, "GILLIAN_C_RUNTIME_PATH": { "scope": "global", "val": "#{self.share}/gillian-c" diff --git a/wisl/lib/ParserAndCompiler/wisl2Gil.ml b/wisl/lib/ParserAndCompiler/wisl2Gil.ml index 4e7a3013e..d4d93988f 100644 --- a/wisl/lib/ParserAndCompiler/wisl2Gil.ml +++ b/wisl/lib/ParserAndCompiler/wisl2Gil.ml @@ -121,7 +121,7 @@ let rec compile_expr ?(fname = "main") ?(is_loop_prefix = false) expr : let cmdl1, comp_expr1 = compile_expr e1 in let cmdl2, comp_expr2 = compile_expr e2 in let call_i_plus = - Cmd.Call + Cmd.call (call_var, internal_func, [ comp_expr1; comp_expr2 ], None, None) in ( cmdl1 @ cmdl2 @@ -573,7 +573,7 @@ let compile_inv_and_while ~fname ~while_stmt ~invariant = in let retv = gen_str gvar in let call_cmd = - Cmd.Call + Cmd.call ( retv, Lit (String loop_fname), List.map (fun x -> Expr.PVar x) vars, @@ -811,7 +811,7 @@ let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = Some (spec_name, List.map (fun x -> (x, Expr.LVar x)) lvars) | None -> None in - let cmd = Cmd.Call (x, expr_fn, params, None, bindings) in + let cmd = Cmd.call (x, expr_fn, params, None, bindings) in let annot = WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () in diff --git a/wisl/lib/debugging/wislLifter.ml b/wisl/lib/debugging/wislLifter.ml index bbbac23b1..c1a0fa84d 100644 --- a/wisl/lib/debugging/wislLifter.ml +++ b/wisl/lib/debugging/wislLifter.ml @@ -57,8 +57,8 @@ struct let get_fun_call_name exec_data = let cmd = CmdReport.(exec_data.cmd_report.cmd) in match cmd with - | Cmd.Call (_, name_expr, _, _, _) -> ( - match name_expr with + | Cmd.Call { fct_name; _ } -> ( + match fct_name with | Expr.Lit (Literal.String name) -> Some name | _ -> failwith "get_fun_call_name: function name wasn't a literal expr!") diff --git a/wisl/lib/semantics/wislSMemory.ml b/wisl/lib/semantics/wislSMemory.ml index b0725279a..c8def7e9f 100644 --- a/wisl/lib/semantics/wislSMemory.ml +++ b/wisl/lib/semantics/wislSMemory.ml @@ -137,13 +137,7 @@ let rem_freed heap pfs gamma loc = let alloc heap _pfs _gamma (size : int) = let loc = WislSHeap.alloc heap size in - Ok - [ - ( heap, - [ Expr.Lit (Literal.Loc loc); Expr.Lit (Literal.Int Z.zero) ], - [], - [] ); - ] + Ok [ (heap, [ Expr.ALoc loc; Expr.Lit (Literal.Int Z.zero) ], [], []) ] let dispose heap pfs gamma loc_expr = match resolve_loc pfs gamma loc_expr with diff --git a/wislfp.opam b/wislfp.opam new file mode 100644 index 000000000..e69de29bb diff --git a/wislfp/.gitignore b/wislfp/.gitignore new file mode 100644 index 000000000..6ebe07d8a --- /dev/null +++ b/wislfp/.gitignore @@ -0,0 +1 @@ +examples/**/*.gil diff --git a/wislfp/bin/dune b/wislfp/bin/dune new file mode 100644 index 000000000..a34404649 --- /dev/null +++ b/wislfp/bin/dune @@ -0,0 +1,9 @@ +; (executables +; (names cwisl wislverify) +; (libraries camelot wisl)) + +(executable + (name wislfp) + (public_name wislfp) + (package wislfp) + (libraries gillian pwSemantics pwParserAndCompiler pwUtils pwDebugging)) diff --git a/wislfp/bin/wislfp.ml b/wislfp/bin/wislfp.ml new file mode 100644 index 000000000..de089c0d0 --- /dev/null +++ b/wislfp/bin/wislfp.ml @@ -0,0 +1,17 @@ +open Gillian.Debugger + +module SMemory = + Gillian.Symbolic.Legacy_s_memory.Modernize (PwSemantics.WislSMemory) + +module CLI = + Gillian.Command_line.Make + (Gillian.General.Init_data.Dummy) + (PwSemantics.WislCMemory) + (SMemory) + (PwParserAndCompiler) + (Gillian.General.External.Dummy (PwParserAndCompiler.Annot)) + (Gillian.Bulk.Runner.DummyRunners) + (Lifter.Gil_fallback_lifter.Make (SMemory) (PwParserAndCompiler) + (PwDebugging.WislLifter.Make)) + +let () = CLI.main () diff --git a/wislfp/dune b/wislfp/dune new file mode 100644 index 000000000..30190a842 --- /dev/null +++ b/wislfp/dune @@ -0,0 +1,3 @@ +(dirs :standard \ node_modules _esy _release) + +(data_only_dirs node_modules _esy _release) diff --git a/wislfp/examples/DLL_recursive.wisl b/wislfp/examples/DLL_recursive.wisl new file mode 100644 index 000000000..e182f3590 --- /dev/null +++ b/wislfp/examples/DLL_recursive.wisl @@ -0,0 +1,137 @@ +// Doubly-linked list segment, unfolding from the left +predicate dlsegl(+x, +y, +v, +w, alpha : List, llen : Int) { + (x == y) * (v == w) * (alpha == nil) * (llen == 0); + (x -> #a, #z, w) * (alpha == #a :: #beta) * dlsegl(#z, y, v, x, #beta, #_llen) * (llen == 1 + #_llen) +} + +// Doubly-linked list segment, unfolding from the right +predicate dlsegr(+x, +y, +v, +w, alpha : List, llen : Int) { + (x == y) * (v == w) * (alpha == nil) * (llen == 0); + (v -> #a, y, #z) * (alpha == #beta @ [#a]) * dlsegr(x, v, #z, w, #beta, #_llen) * (llen == 1 + #_llen) +} + +// Appending an element from the right to the left-unfolding dlseg +lemma dlsegl_append_right { + statement: + forall x, v, z, w, alpha, llen, a, y. + dlsegl(x, v, z, w, alpha, llen) * (v -> a, y, z) |- dlsegl(x, y, v, w, alpha @ [ a ], 1 + llen) + + variant: len alpha + + proof: + unfold dlsegl(x, v, z, w, alpha, llen); + if (alpha = nil) { + fold dlsegl(y, y, v, v, [], 0); + fold dlsegl(x, y, v, w, a :: alpha, 1 + llen) + } else { + assert {bind: #b, #l, #beta, #_llen} (alpha == #b :: #beta) * (x -> #b, #l, w) * dlsegl(#l, v, z, x, #beta, #_llen); + apply dlsegl_append_right(#l, v, z, x, #beta, #_llen, a, y); + fold dlsegl(x, y, v, w, alpha @ [ a ], 1 + llen) + } +} + +// Appending an element from the left to the right-unfolding dlseg +lemma dlsegr_append_left { + statement: + forall x, a, z, w, y, v, alpha, llen. + (x -> a, z, w) * dlsegr(z, y, v, x, alpha, llen) |- dlsegr(x, y, v, w, a :: alpha, 1 + llen) + + variant: len alpha + + proof: + unfold dlsegr(z, y, v, x, alpha, llen); + if (#alpha = nil) { + fold dlsegr(x, x, w, w, [], 0); + fold dlsegr(x, y, v, w, a :: alpha, 1 + llen) + } else { + assert {bind: #b, #l, #beta, #_llen} (alpha == #beta @ [#b]) * (v -> #b, y, #l) * dlsegr(z, v, #l, x, #beta, #_llen); + apply dlsegr_append_left(x, a, z, w, v, #l, #beta, #_llen); + fold dlsegr(x, y, v, w, a :: alpha, 1 + llen) + } +} + +// Left-to-right +lemma dlseg_l_to_r { + statement: + forall x, y, v, w, alpha, llen. + dlsegl(x, y, v, w, alpha, llen) |- dlsegr(x, y, v, w, alpha, llen) + + variant: len alpha + + proof: + unfold dlsegl(x, y, v, w, alpha, llen); + if (alpha = nil) { + fold dlsegr(x, y, v, w, alpha, llen) + } else { + assert {bind: #a, #z, #beta, #_llen} (x -> #a, #z, w) * dlsegl(#z, y, v, x, #beta, #_llen); + apply dlseg_l_to_r(#z, y, v, x, #beta, #_llen); + apply dlsegr_append_left(x, #a, #z, w, y, v, #beta, #_llen) + } +} + +// Right-to-left +lemma dlseg_r_to_l { + statement: + forall x, y, v, w, alpha, llen. + dlsegr(x, y, v, w, alpha, llen) |- dlsegl(x, y, v, w, alpha, llen) + + variant: len alpha + + proof: + unfold dlsegr(x, y, v, w, alpha, llen); + if (alpha = nil) { + fold dlsegl(x, y, v, w, alpha, llen) + } else { + assert {bind: #a, #z, #beta, #_llen} (v -> #a, y, #z) * dlsegr(x, v, #z, w, #beta, #_llen); + apply dlseg_r_to_l(x, v, #z, w, #beta, #_llen); + apply dlsegl_append_right(x, v, #z, w, #beta, #_llen, #a, y) + } +} + +// Doubly-linked list +predicate dlist(+x, +y, alpha, llen) { + dlsegl(x, null, y, null, alpha, llen) +} + +// Concatenation of two dlsegs +lemma dlseg_concat { + statement: + forall x_a, v_a, w_a, alpha, llena, x_b, y_b, v_b, beta, llenb. + dlsegl(x_a, x_b, v_a, w_a, alpha, llena) * dlsegl(x_b, y_b, v_b, v_a, beta, llenb) + |- dlsegl(x_a, y_b, v_b, w_a, (alpha @ beta), llena + llenb) + + proof: + unfold dlsegl(x_a, x_b, v_a, w_a, alpha, llena); + if (alpha != []) { + assert {bind: #a, #z_a, #gamma, #_llena} (x_a -> #a, #z_a, w_a) * dlsegl(#z_a, x_b, v_a, x_a, #gamma, #_llena); + apply dlseg_concat(#z_a, v_a, x_a, #gamma, #_llena, x_b, y_b, v_b, beta, llenb); + fold dlsegl(x_a, y_b, v_b, w_a, (alpha @ beta), llena + llenb) + } +} + +// List concatenation +{ (x_a == #x_a) * (v_a == #v_a) * (x_b == #x_b) * (v_b == #v_b) * + dlist(#x_a, #v_a, #alpha, #llena) * dlist(#x_b, #v_b, #beta, #llenb) } +function concat(x_a, v_a, x_b, v_b) { + r := new(2); + if (x_a = null) { + [r] := x_b; + [r+1] := v_b + } else { + if (x_b = null) { + [r] := x_a; + [r+1] := v_a + } else { + [[ apply dlseg_l_to_r(#x_a, null, #v_a, null, #alpha, #llena) ]]; + [v_a + 1] := x_b; + [x_b + 2] := v_a; + [[ apply dlseg_r_to_l(#x_a, #x_b, #v_a, null, #alpha, #llena) ]]; + [[ apply dlseg_concat(#x_a, #v_a, null, #alpha, #llena, #x_b, null, #v_b, #beta, #llenb) ]]; + [r] := x_a; + [r+1] := v_b + } + }; + return r +} +{ (ret -> #h, #t) * dlist(#h, #t, #alpha @ #beta, #llena + #llenb) } + diff --git a/wislfp/examples/SLL_ex_complete.wisl b/wislfp/examples/SLL_ex_complete.wisl new file mode 100644 index 000000000..e713aa47b --- /dev/null +++ b/wislfp/examples/SLL_ex_complete.wisl @@ -0,0 +1,484 @@ +// +// Standard over-approximating SLL predicate with contents +// +predicate SLL(+x, vs) { + // Empty SLL + (x == null) * (vs == []); + // One SLL node and the rest + (x -b> #v, #next) * SLL(#next, #vs) * + (vs == #v :: #vs) +} + +// +// Pure predicate for list membership +// +predicate list_member(+vs, +v, r : Bool){ + (vs == []) * (r == false); + (vs == v :: #rest) * (r == true) * list_member(#rest, v, #mem); + (vs == #v :: #rest) * (! (#v == v)) * list_member(#rest, v, r) +} + +// +// Lemma: List membership append +// +lemma list_member_append { + statement: + forall vs, v, r, w. + list_member(vs, v, r) |- list_member(vs @ [ w ], v, (r || (w = v))) + + proof: + if (w = v) {} else {}; // FIXME: THIS IS HORRIFIC + unfold list_member(vs, v, r); + if (not (vs = [])) { + assert {bind: #nv, #nvs, #nr} (vs == #nv :: #nvs) * list_member(#nvs, #v, #nr); + apply list_member_append(#nvs, v, #nr, w) + } +} + +// +// Lemma: List membership concat +// +lemma list_member_concat { + statement: + forall vs1, vs2, v. + list_member(vs1, v, #r1) * list_member(vs2, v, #r2) |- list_member(vs1 @ vs2, v, (#r1 || #r2)) + + proof: + unfold list_member(vs1, v, #r1); + if (not (vs1 = [])) { + assert {bind: #nv1, #nvs1, #nr1} (vs1 == #nv1 :: #nvs1) * list_member(#nvs1, v, #nr1); + apply list_member_concat(#nvs1, vs2, v) + } +} + +// 00. Allocating an SLL node with the given value +{ v == #v } +function SLL_allocate_node(v){ + t := new(2); + [t] := v; + return t +} +{ SLL(ret, [ #v ]) } + + +// +// RECURSIVE SLL MANIPULATION +// + +// 01. Prepending a given value to a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +function SLL_prepend(x, k){ + z := SLL_allocate_node(k); + [z + 1] := x; + return z +} +{ SLL(ret, #k :: #vs) } + +// 02. Appending a given value to a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) } +function SLL_append(x, k){ + if (x = null) { + x := SLL_allocate_node(k) + } else { + t := [x + 1]; + z := SLL_append(t, k); + [x + 1] := z + }; + return x +} +{ SLL(ret, #vs @ [#k]) } + +// 03. Appending a given SLL node to a given SLL +{ (x == #x) * (y == #y) * SLL(#x, #vs) * SLL(#y, [#vy]) } +function SLL_append_node(x, y) { + if (x = null) { + x := y + } else { + t := [x + 1]; + z := SLL_append_node(t, y); + [x + 1] := z + }; + return x +} +{ SLL(ret, #vs @ [#vy]) } + +// 04. Concatenating two lists +{(x == #x) * (y == #y) * SLL(#x, #vx) * SLL(#y, #vy) } +function SLL_concat(x, y) { + if (x = null){ + x := y + } else { + t := [x + 1]; + z := SLL_concat(t, y); + [x + 1] := z + }; + return x +} +{ SLL(ret, #vx @ #vy) } + +// 05. Copying a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_copy(x){ + y := null; + if (not (x = null)) { + k := [x]; + y := SLL_allocate_node(k); + t := [x + 1]; + z := SLL_copy(t); + [y + 1] := z + } else { + skip + }; + return y +} +{ SLL(#x, #vs) * SLL(ret, #vs) } + +// 06. Calculating the length of a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_length(x) { + n := 0; + if (x = null){ + n := 0 + } else { + t := [x + 1]; + n := SLL_length(t); + n := 1 + n + }; + return n +} +{ ret == len(#vs) } + +// 07. Reversing a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_reverse(x){ + if (not (x = null)) { + t := [x + 1]; + [x + 1] := null; + z := SLL_reverse(t); + y := SLL_append_node(z, x) + } else { + y := null + }; + return y +} +{ SLL(ret,rev #vs) } + +// 08. Checking if a given value is in a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #r) } +function SLL_member(x, k){ + found := false; + if (x = null){ + skip + } else { + v := [x]; + if (v = k){ + found := true + } else { + t := [x + 1]; + found := SLL_member(t, k) + } + }; + return found +} +{ SLL(#x, #vs) * list_member(#vs, #k, #r) * (ret == #r) } + +// 09. Removing a given value from a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vs) * list_member(#vs, #k, #mem) } +function SLL_remove(x, k) { + if (x = null) { + skip + } else { + v := [x]; + next := [x + 1]; + if (v = k){ + free(x); + x := SLL_remove(next, k) + } else { + z := SLL_remove(next, k); + [x + 1] := z + } + }; + [[ fold list_member([], #k, false) ]]; + return x +} +{ SLL(ret, #nvs) * list_member(#nvs, #k, false) } + +// 10. Freeing a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_free(x){ + if (x = null) { + skip + } else { + t := [x + 1]; + z := SLL_free(t); + free(x) + }; + return null +} +{ (ret == null) } + +// +// ITERATIVE LIST MANIPULATION +// + +// +// Standard over-approximating SLL segment predicate with contents +// +predicate SLLseg(+x, y, vs) { + (x == y) * (vs == []); + (x -b> #v, #next) * SLLseg(#next, y, #vs) * (vs == #v :: #vs) +} + +// +// Lemma: appending a given value to a given SLLseg +// +lemma SSLseg_append { + statement: + forall x, vs, v, z. + SLLseg(x, #y, vs) * (#y -b> v, z) |- SLLseg(x, z, vs @ [ v ]) + + proof: + unfold SLLseg(x, #y, vs); + if (not (x = #y)) { + assert {bind: #nv, #nnext, #nvs} + (x -b> #nv, #nnext) * SLLseg(#nnext, #y, #nvs) * + (vs == #nv :: #nvs); + apply SSLseg_append(#nnext, #nvs, v, z); + fold SLLseg(x, z, vs @ [ v ]) + } else { + fold SLLseg(#y, z, [ v ]) + } +} + +// +// Lemma: an SLLseg followed by an SLL is an SLL +// +lemma SLLseg_concat_SLL { + statement: + forall x, y. + SLLseg(x, y, #vx) * SLL(y, #vy) |- SLL (x, #vx @ #vy) + + proof: + unfold SLLseg(x, y, #vx); + if (not (#vx = [])){ + assert {bind: #nv, #nnext} (x -b> #nv, #nnext); + apply SLLseg_concat_SLL(#nnext, y) + } +} + +// +// Lemma: a null-terminating SLLseg is an SLL +// +lemma SLLseg_to_SLL { + statement: + forall x. + SLLseg(x, null, #vx) |- SLL(x, #vx) + + proof: + unfold SLLseg(x, null, #vx); + if (not (#vx = [])){ + assert {bind: #nv, #nnext} (x -b> #nv, #nnext); + apply SLLseg_to_SLL(#nnext) + } +} + +// 02. Appending a given value to a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #vx) } +function SLL_append_iter(x, k){ + y := SLL_allocate_node(k); + if (x = null) { + x := y + } else { + head := x; + prev := head; + next := [x + 1]; + [[ invariant {bind: prev, next, #vs1, #vs2, #v} + SLLseg(head, prev, #vs1) * (prev -b> #v, next) * SLL(next, #vs2) * + (#vx == #vs1 @ (#v :: #vs2)) ]]; + while(not (next = null)){ + [[ assert {bind: #prev} prev == #prev ]]; + prev := next; + next := [next + 1]; + [[ apply SSLseg_append(head, #vs1, #v, prev) ]] + }; + [prev + 1] := y; + [[ assert {bind: #svs, #sv} SLLseg(head, prev, #svs) * (prev -b> #sv, y) ]]; + [[ apply SSLseg_append(head, #svs, #sv, y) ]]; + [[ assert (SLLseg(head, y, #vx)) ]]; + [[ apply SLLseg_concat_SLL(head, y) ]] + }; + return x +} +{ SLL(ret, #vx @ [ #k ]) } + +// 03. Appending a given node to a given SLL +{ (x == #x) * (y == #y) * SLL(#x, #vs) * SLL(#y, [#vy]) } +function SLL_append_node_iter(x, y){ + if (x = null) { + x := y + } else { + head := x; + prev := head; + next := [x + 1]; + [[ invariant {bind: prev, next, #vs1, #vs2, #v} + SLLseg(head, prev, #vs1) * (prev -b> #v, next) * SLL(next, #vs2) * + (#vx == #vs1 @ (#v :: #vs2)) ]]; + while(not (next = null)){ + [[ assert {bind: #prev} prev == #prev ]]; + prev := next; + next := [next + 1]; + [[ apply SSLseg_append(head, #vs1, #v, prev) ]] + }; + [prev + 1] := y; + [[ assert {bind: #svs, #sv} SLLseg(head, prev, #svs) * (prev -b> #sv, y) ]]; + [[ apply SSLseg_append(head, #svs, #sv, y) ]]; + [[ assert (SLLseg(head, y, #vs)) ]]; // <-- add deliberate bug to #vx + [[ apply SLLseg_concat_SLL(head, y) ]] + }; + return x +} +{ SLL(ret, #vs @ [#vy]) } + +// 04. Concatenating two lists +{(x == #x) * (y == #y) * SLL(#x, #vx) * SLL(#y, #vy) } +function SLL_concat_iter(x, y){ + if (x = null) { + head := y + } else { + head := x; + prev := head; + next := [x + 1]; + [[ invariant {bind: prev, next, #vs1, #vs2, #v} + SLLseg(head, prev, #vs1) * (prev -b> #v, next) * SLL(next, #vs2) * + (#vx == #vs1 @ (#v :: #vs2)) ]]; + while (not (next = null)) { + [[ assert {bind: #prev} prev == #prev ]]; + prev := next; + next := [next + 1]; + [[ apply SSLseg_append(head, #vs1, #v, prev) ]] + }; + [prev + 1] := y; + [[ assert {bind:#svs, #sv} SLLseg(head, prev, #svs) * (prev -b> #sv, y) ]]; + [[ apply SSLseg_append(head, #svs, #sv, y) ]]; + [[ apply SLLseg_concat_SLL(head, y) ]] + }; + return head +} +{ SLL(ret, #vx @ #vy) } + +// 05. Copying a given SLL +{ (x == #x) * SLL(#x, #alpha) } +function SLL_copy_iter(x){ + y := null; + if (x = null){ + skip + } else { + y := new(2); + v := [x]; + [y] := v; + t := [x + 1]; + p := y; + [[ fold SLLseg(x, t, [v]) ]]; + [[ fold SLLseg(y, p, []) ]]; + [[ invariant {bind: c, v, t, p, #alpha1, #alpha2, #alpha3, #a} + SLLseg(x, t, #alpha1) * SLL(t, #alpha2) * (v == #a) * + (#alpha == (#alpha1 @ #alpha2)) * SLLseg(y, p, #alpha3) * (p -b> #a, null) * + (#alpha1 == (#alpha3 @ [#a])) ]]; + while (not (t = null)){ + [[ assert {bind: #t, #p} (t == #t) * (p == #p) ]]; + v := [t]; + c := new(2); + [c] := v; + [p + 1] := c; + p := c; + t := [t + 1]; + [[ apply SSLseg_append(x, #alpha1, v, t) ]]; + [[ apply SSLseg_append(y, #alpha3, #a, p) ]] + }; + [[ assert {bind: #alpha3} SLLseg(y, p, #alpha3) ]]; + [[ apply SSLseg_append(y, #alpha3, v, null) ]]; + [[ apply SLLseg_to_SLL(x) ]]; + [[ apply SLLseg_to_SLL(y) ]] + }; + return y +} +{ SLL(#x, #alpha) * SLL(ret, #alpha) } + +// 06. Calculating the length of a given SLL +{ (x == #x) * SLL(x, #vx) } +function SLL_length_iter(x) { + y := x; + n := 0; + [[invariant {bind: n, y, #nvx, #nvy} + SLLseg(x, y, #nvx) * SLL(y, #nvy) * + (#vx == (#nvx@#nvy)) * (n == len #nvx) ]]; + while (not (y = null)) { + [[ assert {bind: #y} y == #y ]]; + [[ assert {bind: #v, #z} #y -b> #v, #z ]]; + y := [y+1]; + n := n+1; + [[ apply SSLseg_append(x, #nvx, #v, y) ]] + }; + [[ unfold SLL(null, #nvy)]]; + [[ apply SLLseg_to_SLL(x) ]]; + return n +} +{ SLL(#x, #vx) * (ret == len(#vx)) } + +// 07. Reversing a given SLL +// { (x == #x) * SLL(#x, #vx) } +// function SLL_reverse_iter(x) { +// y := null; +// [[ invariant {bind: x, y, z, #nvx, #nvy} +// SLL(x, #nvx) * SLL(y, #nvy) * (#vx == ((rev #nvy) @ #nvx)) ]]; +// while (not (x = null)) { +// z := [x + 1]; +// [x + 1] := y; +// y := x; +// x := z +// }; +// return y +//} +//{ SLL(ret, rev #vx) } + +// 08. Checking if a given value is in a given SLL +{ (x == #x) * (k == #k) * SLL(#x, #alpha) * list_member(#alpha, #k, #r) } +function SLL_member_iter(x, k) { + found := false; + next := x; + [[ invariant {bind: found, next, #beta, #gamma, #rg} + SLLseg(x, next, #beta) * SLL(next, #gamma) * + (#alpha == (#beta @ #gamma)) * (#r == (found || #rg)) * + list_member(#beta, k, found) * list_member(#gamma, k, #rg) ]]; + while ((found = false) && (not (next = null))){ + [[ assert found == false ]]; + [[ assert {bind: #next} next == #next ]]; + [[ assert {bind: #v, #z} #next -b> #v, #z ]]; + v := [next]; + found := (v = k); + next := [next + 1]; + [[ apply SSLseg_append(x, #beta, #v, next) ]]; + [[ unfold list_member(#gamma, k, #rg) ]]; + [[ apply list_member_append(#beta, k, false, #v) ]] + }; + [[ if (found = false) { apply SLLseg_to_SLL(#x); unfold list_member([], #k, false) } else { + assert {bind: #beta, #gamma} SLLseg(#x, next, #beta) * SLL(next, #gamma); + apply list_member_concat(#beta, #gamma, #k); + apply SLLseg_concat_SLL(#x, next) + } ]]; + return found +} +{ SLL(#x, #alpha) * list_member(#alpha, #k, #r) * (ret == #r) } + +// 10. Freeing a given SLL +{ (x == #x) * SLL(#x, #vs) } +function SLL_free_iter(x) { + [[ invariant {bind: x, #rvs} SLL(x, #rvs) ]]; + while (not (x = null)) { + y := x; + x := [x + 1]; + free(y) + }; + return null +} +{ (ret == null) } \ No newline at end of file diff --git a/wislfp/examples/SLL_ex_ongoing.wisl b/wislfp/examples/SLL_ex_ongoing.wisl new file mode 100644 index 000000000..1add1d3ba --- /dev/null +++ b/wislfp/examples/SLL_ex_ongoing.wisl @@ -0,0 +1,518 @@ +// +// SLL predicates +// + +// With addresses, including first +predicate SLL_addrs_incl(+x, xs : List) { + // Empty SLL + (x == null) * (xs == []); + // One SLL node and the rest + (x -b> #v, #y) * SLL_addrs_incl(#y, #xs) * (xs == x :: #xs) +} + +// With addresses, excluding first +predicate SLL_addrs_excl(+x, xs : List) { + // Empty SLL + (x == null) * (xs == []); + // One SLL node and the rest + (x -b> #v, #y) * SLL_addrs_excl(#y, #xs) * (xs == #y :: #xs) +} + +// With values +predicate SLL_vals(+x, vs : List) { + // Empty SLL + (x == null) * (vs == []); + // One SLL node and the rest + (x -b> #v, #y) * SLL_vals(#y, #vs) * (vs == #v :: #vs) +} + +// With addresses, including first, and values +predicate SLL_incl(+x, xs : List, vs : List) { + // Empty SLL + (x == null) * (xs == []) * (vs == []); + // One SLL node and the rest + (x -b> #v, #y) * SLL_incl(#y, #xs, #vs) * (xs == x :: #xs) * (vs == #v :: #vs) +} + +// With addresses, excluding first, and values +predicate SLL_excl(+x, xs : List, vs : List) { + // Empty SLL + (x == null) * (xs == []) * (vs == []); + // One SLL node and the rest + (x -b> #v, #y) * SLL_excl(#y, #xs, #vs) * (xs == #y :: #xs) * (vs == #v :: #vs) +} + +// With length +predicate SLL_len(+x, n : Int) { + // Empty SLL + (x == null) * (n == 0); + // One SLL node and the rest + (x -b> #v, #y) * SLL_len(#y, n - 1) +} + +// +// SLLseg predicates +// + +// With length +predicate SLLseg_len(+x, y, n : Int) { + (x == y) * (n == 0); + (x -b> #v, #z) * SLLseg_len(#z, y, n - 1) * (0 <# n) +} + +// With values +predicate SLLseg_vals(+x, y, vs) { + (x == y) * (vs == []); + (x -b> #v, #next) * SLLseg_vals(#next, y, #vs) * (vs == #v :: #vs) +} + +// +// Pure predicate for list membership +// + +predicate list_member(+vs, +v, r : Bool) { + (vs == []) * (r == false); + (vs == v :: #rest) * (r == true) * list_member(#rest, v, #mem); + (vs == #v :: #rest) * (! (#v == v)) * list_member(#rest, v, r) +} + +// +// Predicate for freed list nodes +// +predicate freed_nodes(xs) { + (xs == [ null ]); + (xs == #x :: #xs) * freed(#x) * freed_nodes(#xs) +} + +// +// +// Lemmas +// +// + +// SLLseg_vals + trailing node -> larger, non-empty SLLseg_vals +lemma SSLseg_vals_append { + statement: + forall x. + SLLseg_vals(#x, #y, #vs) * (#y -b> #v, #z) |- SLLseg_vals(#x, #z, #vs @ [ #v ]) + + variant: (len #vs) + + proof: + unfold SLLseg_vals(#x, #y, #vs); + if (not (#x = #y)) { + assert {bind: #nnext} (#x + 1 -> #nnext); + apply SSLseg_vals_append(#nnext); + fold SLLseg_vals(#x, #z, #vs @ [ #v ]) + } else { + fold SLLseg_vals(#y, #z, [ #v ]) + } +} + +// SLLseg_vals + SLL_vals -> SLL_vals +lemma SLLseg_vals_concat_SLL_vals { + statement: + forall x. + SLLseg_vals(#x, #y, #vx) * SLL_vals(#y, #vy) |- SLL_vals (#x, #vx @ #vy) + + variant: (len #vx) + + proof: + unfold SLLseg_vals(#x, #y, #vx); + if (not (#vx = [])){ + assert {bind: #nnext} (#x + 1 -> #nnext); + apply SLLseg_vals_concat_SLL_vals(#nnext) + } +} + +// A null-terminating SLLseg_vals is an SLL_vals +lemma SLLseg_vals_to_SLL_vals { + statement: + forall x. + SLLseg_vals(#x, null, #vs) |- SLL_vals(#x, #vs) + + variant: len #vs + + proof: + unfold SLLseg_vals(#x, null, #vs); + if (not (#vs = [])) { + assert {bind: #nv, #nnext} (#x -b> #nv, #nnext); + apply SLLseg_vals_to_SLL_vals(#nnext) + }; + fold SLL_vals(#x, #vs) +} + +// SLLseg_len + trailing node -> larger, non-empty SLLseg_len +lemma SSLseg_len_append_lr { + statement: + forall x. + SLLseg_len(#x, #y, #n) * (#y -b> #v, #z) |- SLLseg_len(#x, #z, #n + 1) * (0 <=# #n) + + variant: #n + + proof: + unfold SLLseg_len(#x, #y, #n); + if (not (#n = 0)) { + assert {bind: #nnext} (#x + 1 -> #nnext); + apply SSLseg_len_append_lr(#nnext) + }; + fold SLLseg_len(#x, #z, #n + 1) +} + +// non-empty SLLseg_len -> smaller SLLseg_len + trailing node +lemma SSLseg_len_append_rl { + statement: + forall x. + SLLseg_len(#x, #z, #n + 1) * (0 <=# #n) |- SLLseg_len(#x, #y, #n) * (#y -b> #v, #z) + + variant: #n + + proof: + unfold SLLseg_len(#x, #z, #n + 1); + assert {bind: #nnext} (#x + 1 -> #nnext); + if (not (#n = 0)) { + apply SSLseg_len_append_rl(#nnext); + assert {bind: #y} SLLseg_len(#nnext, #y, #n - 1); + fold SLLseg_len(#x, #y, #n) + } +} + +// A null-terminating SLLseg_len is an SLL_len +lemma SLLseg_len_to_SLL_len { + statement: + forall x. + SLLseg_len(#x, null, #n) |- SLL_len(#x, #n) + + variant: #n + + proof: + unfold SLLseg_len(#x, null, #n); + if (not (#n = 0)) { + assert {bind: #nv, #nnext} (#x -b> #nv, #nnext); + apply SLLseg_len_to_SLL_len(#nnext) + }; + fold SLL_len(#x, #n) +} + +// List membership-concat compatibility +lemma list_member_concat { + statement: + forall vs1, vs2, v. + list_member(#vs1, #v, #r1) * list_member(#vs2, #v, #r2) |- list_member(#vs1 @ #vs2, #v, (#r1 || #r2)) + + variant: len #vs1 + + proof: + unfold list_member(#vs1, #v, #r1); + if (not (#vs1 = [])) { + assert {bind: #nv1, #nvs1, #nr1} (#vs1 == #nv1 :: #nvs1) * list_member(#nvs1, v, #nr1); + apply list_member_concat(#nvs1, #vs2, #v) + } +} + +// +// +// Examples +// +// + +// +// 00. Allocating an SLL node with the given value +// +function SLL_allocate_node(v){ + t := new(2); + [t] := v; + return t +} + +// +// 01. Prepending a given value to a given SLL +// + +// General pre-condition +predicate SLL_prepend_pre(def, +x, xs, vs, n) { + (def == 0) * SLL_addrs_incl(x, xs) * (vs == []) * (n == 0); + (def == 2) * SLL_vals(x, vs) * (xs == []) * (n == 0); + (def == 3) * SLL_incl(x, xs, vs) * (n == 0); + (def == 5) * SLL_len(x, n) * (xs == []) * (vs == []) +} + +// General post-condition +predicate SLL_prepend_post(+def, +x, +xs, +k, +vs, +n, +retval) { + (def == 0) * SLL_addrs_incl(retval, retval :: xs); + (def == 2) * SLL_vals(retval, k :: vs); + (def == 3) * SLL_incl(retval, retval :: xs, k :: vs); + (def == 5) * SLL_len(retval, n + 1) * (xs == []) +} + +// Specified algorithm +{ (x == #x) * (k == #k) * SLL_prepend_pre(#def, #x, #xs, #vs, #n) } +function SLL_prepend(x, k){ + z := SLL_allocate_node(k); + [z + 1] := x; + return z +} +{ SLL_prepend_post(#def, #x, #xs, #k, #vs, #n, ret) } + +// +// 02r. List length +// + +// General pre-condition +predicate SLL_length_pre(def, +x, var : Int) { + (def == 0) * SLL_addrs_incl(x, #xs) * (var == len #xs); + (def == 1) * SLL_addrs_excl(x, #xs) * (var == len #xs); + (def == 2) * SLL_vals(x, #vs) * (var == len #vs); + (def == 3) * SLL_incl(x, #xs, #vs) * (var == len #xs); + (def == 4) * SLL_excl(x, #xs, #vs) * (var == len #xs); + (def == 5) * SLL_len(x, #n) * (var == #n) +} + +// General post-condition +predicate SLL_length_post(+def, +x, +retval) { + (def == 0) * SLL_addrs_incl(x, #xs) * (retval == len #xs); + (def == 1) * SLL_addrs_excl(x, #xs) * (retval == len #xs); + (def == 2) * SLL_vals(x, #vs) * (retval == len #vs); + (def == 3) * SLL_incl(x, #xs, #vs) * (retval == len #xs); + (def == 4) * SLL_excl(x, #xs, #vs) * (retval == len #xs); + (def == 5) * SLL_len(x, retval) +} + +// Specified algorithm +{ (x == #x) * SLL_length_pre(#def, #x, #var) } with variant: #var +function SLL_length(x) { + if (x = null){ + n := 0 + } else { + t := [x + 1]; + n := SLL_length(t); + n := 1 + n + }; + return n +} +{ SLL_length_post(#def, #x, ret) } + +// +// 02i. List Length +// + +// Specified algorithm +{ (x == #x) * SLL_len(x, #n) } +function SLL_length_iter(x) { + y := x; + n := 0; + [[ invariant {bind: n, y, #ny} + SLLseg_len(x, y, n) * SLL_len(y, #ny) * (#n == n + #ny) + with variant: #ny ]]; + while (not (y = null)) { + y := [y + 1]; + n := n + 1; + [[ apply SSLseg_len_append_lr(x) ]] + }; + [[ apply SLLseg_len_to_SLL_len(x) ]]; + return n +} +{ SLL_len(#x, #n) * (ret == n) } + +// +// 03r. List concatenation +// + +// General pre-condition +predicate SLL_concat_pre(def, +x, +y, xx, xy, vx, vy, nx, ny, var : Int) { + (def == 0) * SLL_addrs_incl(x, xx) * SLL_addrs_incl(y, xy) * (vx == []) * (vy == []) * (nx == 0) * (ny == 0) * (var == len xx); + (def == 2) * SLL_vals(x, vx) * SLL_vals(y, vy) * (xx == []) * (xy == []) * (nx == 0) * (ny == 0) * (var == len vx); + (def == 3) * SLL_incl(x, xx, vx) * SLL_incl(y, xy, vy) * (nx == 0) * (ny == 0) * (var == len vx); + (def == 5) * SLL_len(x, nx) * SLL_len(y, ny) * (xx == []) * (xy == []) * (vx == []) * (vy == []) * (var == nx) +} + +// General post-condition +predicate SLL_concat_post(+def, +x, +y, +xx, +xy, +vx, +vy, +nx, +ny, +retval) { + (def == 0) * SLL_addrs_incl(retval, xx @ xy); + (def == 2) * SLL_vals(retval, vx @ vy); + (def == 3) * SLL_incl(retval, xx @ xy, vx @ vy); + (def == 5) * SLL_len(retval, nx + ny) +} + +// Specified algorithm +{(x == #x) * (y == #y) * SLL_concat_pre(#def, #x, #y, #xx, #xy, #vx, #vy, #nx, #ny, #var) } with variant: #var +function SLL_concat(x, y) { + if (x = null){ + x := y + } else { + t := [x + 1]; + z := SLL_concat(t, y); + [x + 1] := z + }; + return x +} +{ SLL_concat_post(#def, #x, #y, #xx, #xy, #vx, #vy, #nx, #ny, ret) } + +// +// 03i. List concatenation +// + +// Specified algorithm +{(x == #x) * (y == #y) * SLL_vals(#x, #vx) * SLL_vals(#y, #vy) } +function SLL_concat_iter(x, y){ + if (x = null) { + head := y + } else { + head := x; + prev := head; + next := [x + 1]; + [[ invariant {bind: prev, next, #vs1, #vs2, #v} + SLLseg_vals(head, prev, #vs1) * (prev -b> #v, next) * SLL_vals(next, #vs2) * + (#vx == #vs1 @ (#v :: #vs2)) with variant: (len #vs2) ]]; + while (not (next = null)) { + prev := next; + next := [next + 1]; + [[ apply SSLseg_vals_append(head) ]] + }; + [prev + 1] := y; + [[ apply SSLseg_vals_append(head) ]]; + [[ apply SLLseg_vals_concat_SLL_vals(head) ]] + }; + return head +} +{ SLL_vals(ret, #vx @ #vy) } + +// +// 04r. Reversing a given SLL +// + +// General pre-condition +predicate SLL_reverse_pre(def, +x, xs, vs, n, var) { + (def == 0) * SLL_addrs_incl(x, xs) * (vs == []) * (n == 0) * (var == len xs); + (def == 2) * SLL_vals(x, vs) * (xs == []) * (n == 0) * (var == len vs); + (def == 3) * SLL_incl(x, xs, vs) * (n == 0) * (var == len xs); + (def == 5) * SLL_len(x, n) * (xs == []) * (vs == []) * (var == n) +} + +// General post-condition +predicate SLL_reverse_post(+def, +x, +xs, +vs, +n, +retval) { + (def == 0) * SLL_addrs_incl(retval, rev xs) * (vs == []) * (n == 0); + (def == 2) * SLL_vals(retval, rev vs) * (xs == []) * (n == 0); + (def == 3) * SLL_incl(retval, rev xs, rev vs) * (n == 0); + (def == 5) * SLL_len(retval, n) * (xs == []) * (vs == []) +} + +// Specified algorithm +{ (x == #x) * SLL_reverse_pre(#def, #x, #xs, #vs, #n, #var) } with variant: #var +function SLL_reverse(x){ + if (not (x = null)) { + t := [x + 1]; + [x + 1] := null; + z := SLL_reverse(t); + y := SLL_concat(z, x) + } else { + y := null + }; + return y +} +{ SLL_reverse_post(#def, #x, #xs, #vs, #n, ret) } + +// +// 05r. List Membership +// + +// General pre-condition +predicate SLL_member_pre(def, +x, vs, var : Int) { + (def == 2) * SLL_vals(x, vs) * (var == len vs); + (def == 3) * SLL_incl(x, #xs, vs) * (var == len vs); + (def == 4) * SLL_excl(x, #xs, vs) * (var == len vs) +} + +predicate nounfold SLL_member_post(+def, +x, +vs) { + (def == 2) * SLL_vals(x, vs); + (def == 3) * SLL_incl(x, #xs, vs); + (def == 4) * SLL_excl(x, #xs, vs) +} + +// Specified algorithm +{ (x == #x) * (k == #k) * SLL_member_pre(#def, #x, #vs, #var) * list_member(#vs, #k, #r) } with variant: #var +function SLL_member(x, k){ + found := false; + if (x = null){ + skip + } else { + v := [x]; + if (v = k){ + found := true + } else { + t := [x + 1]; + found := SLL_member(t, k) + } + }; + return found +} +{ SLL_member_post(#def, #x, #vs) * list_member(#vs, #k, #r) * (ret == #r) } + +// +// 05i. List membership +// +{ (x == #x) * (k == #k) * SLL_vals(#x, #vs) * list_member(#vs, #k, #r) } +function SLL_member_iter(x, k) { + found := false; + next := x; + [[ invariant {bind: found, next, #beta, #gamma, #rg} + SLLseg_vals(x, next, #beta) * SLL_vals(next, #gamma) * + (#alpha == (#beta @ #gamma)) * (#r == (found || #rg)) * + list_member(#beta, k, found) * list_member(#gamma, k, #rg) + with variant: (len #gamma) ]] ; + while ((found = false) && (not (next = null))) { + [[ assert found == false ]]; + [[ assert {bind: #v} next -> #v ]]; + v := [ next ]; + found := (v = k); + next := [next + 1]; + [[ apply SSLseg_vals_append(x) ]]; + [[ unfold list_member(#gamma, k, #rg) ]]; + [[ apply list_member_concat(#beta, [ #v ], k) ]] + }; + [[ + if (found = false) { + apply SLLseg_vals_to_SLL_vals(#x) + } else { + assert {bind: #beta, #gamma} SLLseg_vals(#x, next, #beta) * SLL_vals(next, #gamma); + apply list_member_concat(#beta, #gamma, #k); + apply SLLseg_vals_concat_SLL_vals(#x) + } + ]]; + return found +} +{ SLL_vals(#x, #vs) * list_member(#vs, #k, #r) * (ret == #r) } + +// +// 06r. Freeing a given SLL +// + +// General pre-condition +predicate SLL_free_pre(def, +x, xs, var : Int) { + (def == 0) * SLL_addrs_incl(x, xs) * (var == len xs); + (def == 1) * SLL_addrs_excl(x, xs) * (var == len xs); + (def == 3) * SLL_incl(x, xs, #vs) * (var == len xs); + (def == 4) * SLL_excl(x, xs, #vs) * (var == len xs) +} + +// General post-condition +predicate SLL_free_post(+def, +x, +xs) { + (def == 0) * freed_nodes(xs @ [ null ]); + (def == 1) * freed_nodes(x :: xs); + (def == 3) * freed_nodes(xs @ [ null ]); + (def == 4) * freed_nodes(x :: xs) +} + +// Specified algorithm +{ (x == #x) * SLL_free_pre(#def, #x, #xs, #var) } with variant: #var +function SLL_free(x){ + if (x = null) { + skip + } else { + t := [x + 1]; + z := SLL_free(t); + free(x) + }; + return null +} +{ (ret == null) * SLL_free_post(#def, #x, #xs)} \ No newline at end of file diff --git a/wislfp/examples/SLL_iterative.wisl b/wislfp/examples/SLL_iterative.wisl new file mode 100644 index 000000000..e469fa53e --- /dev/null +++ b/wislfp/examples/SLL_iterative.wisl @@ -0,0 +1,99 @@ +predicate list(+x, alpha) { + (x == null) * (alpha == nil); + (x -> #v, #z) * list(#z, #beta) * (alpha == #v::#beta) +} + +predicate lseg(+x, +y, alpha) { + (x == y) * (alpha == nil); + (x -> #v, #z) * lseg(#z, y, #beta) * (alpha == #v::#beta) +} + +lemma lseg_to_list(x, alpha) { + variant: len alpha + hypothesis: (x == #x) * (alpha == #alpha) * lseg(#x, null, #alpha) + conclusion: list(#x, #alpha) + proof: unfold lseg(#x, null, #alpha); + if (not (#x = null)) { + assert {exists: #next, #beta} (#x + 1 -> #next) * lseg(#next, null, #beta) ; + apply lseg_to_list(#next, #beta); + fold list(#x, #alpha) + } else { + fold list(#x, #alpha) + } +} + +lemma concat_lseg_list(x, y, beta) { + variant: len beta + hypothesis: (x == #x) * (y == #y) * (beta == #beta) * lseg(#x, #y, #alpha) * list(#y, #beta) + conclusion: list(#x, #alpha @ #beta) + proof: unfold list (#y, #beta); + if (#y = null) { + apply lseg_to_list(#x, #alpha) + } else { + assert (!(#y == null)); + unfold list(#y, #beta); + assert (#y -> #z, #t) * list(#t, #rest) * (#beta == #z::#rest); + apply lseg_append(#x, #y, #alpha, #z, #t); + apply concat_lseg_list(#x, #t, #rest) + } +} + + +lemma lseg_append(x, y, alpha, yval, ynext) { + variant: len alpha + hypothesis: (x == #x) * (y == #y) * (alpha == #alpha) * + (yval == #yval) * (ynext == #ynext) * + lseg(#x, #y, #alpha) * (#y -> #yval, #ynext) + conclusion: lseg(#x, #ynext, #alpha @ [ #yval ]) + proof: unfold lseg(#x, #y, #alpha); + if (not (#alpha = [])) { + assert {exists: #next, #beta} (#x + 1 -> #next) * lseg(#next, #y, #beta) ; + apply lseg_append(#next, #y, #beta, #yval, #ynext); + fold lseg(#x, #ynext, #alpha @ [#yval]) + } else { + fold lseg(#x, #ynext, #alpha @ [#yval]) + } +} + + +{ (#x == x) * list(#x, #alpha) } +function llen(x) { + y := x; + n := 0; + [[invariant {exists: #a1, #a2} lseg(#x, y, #a1) * list(y, #a2) * (#alpha == #a1@#a2) * (n == len #a1) ]]; + while (y != null) { + [[ assert {exists: #z} y == #z ]]; + [[ assert {exists: #b, #t} #z -> #b, #t ]]; + y := [y+1]; + n := n+1; + [[ apply lseg_append(#x, #z, #a1, #b, #t) ]] + }; + [[ unfold list(null, #a2) ]]; + [[ apply lseg_to_list(#x, #alpha) ]]; + return n +} +{ list(#x, #alpha) * (ret == len(#alpha)) } + + +{ (x == #x) * (y == #y) * list(#x, #alpha) * list(#y, #beta) } +function concat(x, y) { + if (x = null) { + x := y + } else { + t := x; + n := [x+1]; + [[ invariant {exists: #a1, #a2, #b} lseg(#x, t, #a1) * (t -> #b, n) * list(n, #a2) * (#alpha == #a1 @ [#b] @ #a2) ]]; + while (n != null) { + [[ assert {exists: #t} (t == #t) ]]; + t := n; + n := [t+1]; + [[ apply lseg_append(#x, #t, #a1, #b, t) ]] + }; + [t+1] := y; + [[ assert {exists: #some_list, #z} lseg(#x, t, #some_list) * (t -> #z, #y) ]]; + [[ apply lseg_append(#x, t, #some_list, #z, #y) ]]; + [[ apply concat_lseg_list(#x, #y, #beta) ]] + }; + return x +} +{ list(ret, #alpha @ #beta) } \ No newline at end of file diff --git a/wislfp/examples/SLL_recursive.wisl b/wislfp/examples/SLL_recursive.wisl new file mode 100644 index 000000000..068d8ac6f --- /dev/null +++ b/wislfp/examples/SLL_recursive.wisl @@ -0,0 +1,76 @@ +predicate list(+x, alpha) { + (x == null) * (alpha == nil); + (x -b> #v, #z) * list(#z, #beta) * (alpha == #v::#beta) +} + +{ (x == #x) * list(#x, #alpha) } +function llen(x) { + if (x = null) { + n := 0 + } else { + t := [x+1]; + n := llen(t); + n := n + 1 + }; + return n +} +{ list(#x, #alpha) * (ret == len(#alpha)) } + +{ (x == #x) * (y == #y) * list(#x, #alpha) * list(#y, #beta) } +function concat(x, y) { + if (x = null) { + r := y + } else { + t := [x+1]; + ct := concat(t, y); + [x+1] := ct; + r := x + }; + return r +} +{ list(ret, #alpha @ #beta) } + + +{ list(#x, #alpha) * (v == #v) * (x == #x) } +function append(x, v) { + if (x = null) { + y := new(2); + [y] := v + } else { + t := [x+1]; + tp := append(t, v); + [x+1] := tp; + y := x + }; + return y +} +{ list(ret, #alpha@[#v]) } + +{ list(x, #alpha) * (x == #x) } +function copy(x) { + if (x = null) { + ch := null + } else { + v := [x]; + t := [x+1]; + ct := copy(t); + ch := new(2); + [ch] := v; + [ch + 1] := ct + }; + return ch +} +{ list(#x, #alpha) * list(ret, #alpha) } + +// { list(x, #alpha) } +// function dispose_list(x) { +// if (x = null) { +// skip +// } else { +// tail := [x+1]; +// u := dispose_list(tail); +// dispose(x) +// }; +// return null +// } +// { emp } \ No newline at end of file diff --git a/wislfp/examples/dune b/wislfp/examples/dune new file mode 100644 index 000000000..5acd79c27 --- /dev/null +++ b/wislfp/examples/dune @@ -0,0 +1,7 @@ +(copy_files ../runtime/*.gil) + +(rule + (deps wisl_core.gil wisl_pointer_arith.gil DLL_recursive.wisl) + (alias runtest) + (action + (run wisl verify -l disabled -R . DLL_recursive.wisl))) diff --git a/wislfp/examples/loop.wisl b/wislfp/examples/loop.wisl new file mode 100644 index 000000000..b502d75ca --- /dev/null +++ b/wislfp/examples/loop.wisl @@ -0,0 +1,63 @@ + +predicate list(+x, alpha) { + (x == null) * (alpha == nil); + (x -> #a, #z) * (alpha == #a :: #beta) * list(#z, #beta) +} + +predicate lseg(+x, +y, alpha) { + (x == y) * (alpha == nil); + (x -> #a, #z) * (alpha == #a :: #beta) * lseg(#z, y, #beta) +} + +lemma lseg_to_list(x, alpha) { + variant: len alpha + hypothesis: (x == #x) * (alpha == #alpha) * lseg(#x, null, #alpha) + conclusion: list(#x, #alpha) + proof: unfold lseg(#x, null, #alpha); + if (#x = null) { + fold list(#x, #alpha) + } else { + assert {exists: #next, #beta} (#x + 1 -> #next) * lseg(#next, null, #beta); + apply lseg_to_list(#next, #beta); + fold list(#x, #alpha) + } +} + +lemma lseg_append(x, y, alpha, a, z) { + variant: len alpha + + hypothesis: (x == #x) * (y == #y) * (alpha == #alpha) * (a == #a) * (z == #z) * + lseg(#x, #y, #alpha) * + (#y -> #a, #z) + + conclusion: lseg(#x, #z, #alpha @ [ #a ]) + + + proof: unfold lseg(#x, #y, #alpha); + if (#alpha = []) { + fold lseg(#x, #z, #alpha @ [#a]) + } else { + assert {exists: #next, #beta} (#x + 1 -> #next) * lseg(#next, #y, #beta); + apply lseg_append(#next, #y, #beta, #a, #z); + fold lseg(#x, #z, #alpha @ [#a]) + } +} + +{ (x == #x) * list(#x, #alpha) } +function llen(x) { + y := x; + n := 0; + [[ fold lseg(#x, y, []) ]]; + [[ invariant {exists: #a1, #a2} lseg(#x, y, #a1) * list(y, #a2) * (#alpha == #a1 @ #a2) * (n == len #a1) ]]; + while (y != null) { + [[ unfold list(y, #a2) ]]; + [[ assert {exists: #y, #b, #t} (y == #y) * (#y -> #b, #t) ]]; + y := [y+1]; + n := n+1; + [[ apply lseg_append(#x, #y, #a1, #b, #t) ]] + }; + [[ apply lseg_to_list(#x, #alpha) ]]; + return n +} +{ list(#x, alpha) * (ret == len(#alpha)) } + diff --git a/wislfp/examples/tree.wisl b/wislfp/examples/tree.wisl new file mode 100644 index 000000000..15d79de7f --- /dev/null +++ b/wislfp/examples/tree.wisl @@ -0,0 +1,19 @@ +predicate tree(+t) { + (t == null); + (t -b-> #v, #left, #right) * tree(#left) * tree(#right) +} + +{ (x == #x) * tree(#x) } +function tree_dispose(x) { + if (x != null) { + y := [x+1]; + z := [x+2]; + u := tree_dispose(y); + u := tree_dispose(z); + delete(x) + } else { + skip + }; + return null +} +{ emp } \ No newline at end of file diff --git a/wislfp/lib/ParserAndCompiler/WAnnot.ml b/wislfp/lib/ParserAndCompiler/WAnnot.ml new file mode 100644 index 000000000..c2933c24d --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/WAnnot.ml @@ -0,0 +1,34 @@ +type nest_kind = + | NoNest (** This command doesn't contain a nest *) + | Proc of string + (** This command "nests" the execution of another (named) procedure *) +[@@deriving yojson] + +type stmt_end_kind = NotEnd | EndNormal | EndWithBranch of WBranchCase.t +[@@deriving yojson] + +(** How does this command map to a WISL statment? *) +type stmt_kind = + | Single (** A command that maps one-to-one with a WISL statement *) + | LoopPrefix (** A command in the prefix of a loop body function *) + | Multi of stmt_end_kind + (** A command that makes up part of a WISL statement, and whether this is the last cmd of said statement *) +[@@deriving yojson] + +type t = { + origin_loc : Gil_syntax.Location.t option; + (** Better not to know what this is for *) + origin_id : int option; (** Origin Id, that should be abstracted away *) + loop_info : string list; + stmt_kind : stmt_kind; [@default Single] + nest_kind : nest_kind; [@default NoNest] + is_hidden : bool; [@default false] + (** Should this command be hidden when debugging? *) +} +[@@deriving yojson, make] + +let make_basic ?origin_loc ?loop_info () = make ?origin_loc ?loop_info () +let get_origin_loc { origin_loc; _ } = origin_loc +let get_loop_info { loop_info; _ } = loop_info +let set_loop_info loop_info annot = { annot with loop_info } +let is_hidden { is_hidden; _ } = is_hidden diff --git a/wislfp/lib/ParserAndCompiler/WLexer.mll b/wislfp/lib/ParserAndCompiler/WLexer.mll new file mode 100644 index 000000000..745342f04 --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/WLexer.mll @@ -0,0 +1,165 @@ +{ + open Lexing + open CodeLoc + open WParser + + exception SyntaxError of string + let l_start_string = ref CodeLoc.dummy +} + + +let digit = ['0'-'9'] +let letter = ['a'-'z''A'-'Z'] +let gvars = "gvar_" digit+ (* generated variables during compilation *) +let identifier = letter(letter|digit|'_')* +let lvar = '#' (letter|digit|'_'|'$')* +let integer = digit+ +let float = digit* '.' digit* +let loc = "$l" (letter|digit|'_')* +let white = [' ' '\t']+ +let newline = '\r' | '\n' | "\r\n" + +rule read = + parse + (* keywords *) + | "true" { TRUE (curr lexbuf) } + | "false" { FALSE (curr lexbuf) } + | "True" { LTRUE (curr lexbuf) } + | "False" { LFALSE (curr lexbuf) } + | "nil" { LSTNIL (curr lexbuf) } + | "null" { NULL (curr lexbuf) } + | "while" { WHILE (curr lexbuf) } + | "if" { IF (curr lexbuf) } + | "else" { ELSE (curr lexbuf) } + | "skip" { SKIP (curr lexbuf) } + | "new" { NEW (curr lexbuf) } + | "free" { DELETE (curr lexbuf) } + | "dispose"{ DELETE (curr lexbuf) } + | "function" { FUNCTION (curr lexbuf) } + | "par" { PAR (curr lexbuf) } + | "predicate" { PREDICATE (curr lexbuf) } + | "invariant" { INVARIANT (curr lexbuf) } + | "return" { RETURN (curr lexbuf) } + | "fold" { FOLD (curr lexbuf) } + | "unfold" { UNFOLD (curr lexbuf) } + | "nounfold" { NOUNFOLD (curr lexbuf) } + | "apply" { APPLY (curr lexbuf) } + | "assert" { ASSERT (curr lexbuf) } + | "with" { WITH (curr lexbuf) } + | "variant" { VARIANT (curr lexbuf) } + | "statement" { STATEMENT (curr lexbuf) } + | "proof" { PROOF (curr lexbuf) } + | "lemma" { LEMMA (curr lexbuf) } + | "forall" { FORALL (curr lexbuf) } + | "bind" { EXIST (curr lexbuf) } + | "spec" { SPEC (curr lexbuf) } + (* types *) + | "List" { TLIST (curr lexbuf) } + | "Int" { TINT (curr lexbuf) } + | "Bool" { TBOOL (curr lexbuf) } + | "Float" { TFLOAT (curr lexbuf) } + (* strings and comments *) + | '"' { let () = l_start_string := curr lexbuf in + read_string (Buffer.create 17) lexbuf } + | "//" { read_comment lexbuf } + (* logical binary stuff *) + | "->" { ARROW } + | "-b>" { BLOCK_ARROW } + | "/\\" { LAND } + | "\\/" { LOR } + | "==" { LEQ } + | "<#" { LLESS } + | "f<#" { FLLESS } + | "<=#" { LLESSEQ } + | "f<=#" { FLLESSEQ } + | ">#" { LGREATER } + | "f>#" { FLGREATER } + | ">=#" { LGREATEREQ } + | "f>=#" { FLGREATEREQ } + (* punctuation *) + | "-{" { SETOPEN (curr lexbuf) } + | "}-" { SETCLOSE (curr lexbuf) } + | "[[" { LOGOPEN (curr lexbuf) } + | "]]" { LOGCLOSE(curr lexbuf) } + | '[' { LBRACK (curr lexbuf) } + | ']' { RBRACK (curr lexbuf) } + | '{' { LCBRACE (curr lexbuf) } + | '}' { RCBRACE (curr lexbuf) } + | '(' { LBRACE (curr lexbuf) } + | ')' { RBRACE (curr lexbuf) } + | ":=" { ASSIGN (curr lexbuf) } + | ':' { COLON (curr lexbuf) } + | ',' { COMMA (curr lexbuf) } + | "." { DOT (curr lexbuf) } + | ';' { SEMICOLON (curr lexbuf) } + | "|-" { VDASH (curr lexbuf) } + (* binary operators *) + | "::" { LSTCONS } + | '@' { LSTCAT } + | '=' { EQUAL } + | ">=" { GREATEREQUAL } + | "f>=" { FGREATEREQUAL } + | '>' { GREATERTHAN } + | "f>" { FGREATERTHAN } + | '<' { LESSTHAN } + | "f<" { FLESSTHAN } + | "<=" { LESSEQUAL } + | "f<=" { FLESSEQUAL } + | '+' { PLUS } + | "f+" { FPLUS } + | '-' { MINUS } + | "f-" { FMINUS } + | '*' { TIMES } + | "f*" { FTIMES } + | '/' { DIV } + | "f/" { FDIV } + | '%' { MOD } + | "f%" { FMOD } + | "&&" { AND } + | "||" { OR } + | "!=" { NEQ } + | "lnth" { LSTNTH } + (* unary operators *) + | "not" { NOT (curr lexbuf) } + | "emp" { EMP (curr lexbuf) } + | "len" { LEN (curr lexbuf) } + | "hd" { HEAD (curr lexbuf) } + | "tl" { TAIL (curr lexbuf) } + | "rev" { REV (curr lexbuf) } + | "sub" { SUB (curr lexbuf) } + | '!' { LNOT (curr lexbuf) } + (* identifiers *) + | white { read lexbuf } + | newline { new_line lexbuf; read lexbuf } + | float { FLOAT (curr lexbuf, float_of_string (Lexing.lexeme lexbuf)) } + | integer { INTEGER (curr lexbuf, int_of_string (Lexing.lexeme lexbuf)) } + | gvars { IDENTIFIER (curr lexbuf, (Lexing.lexeme lexbuf)^"_user") } (* if it has a name of generated var, we add _user *) + | identifier { IDENTIFIER (curr lexbuf, Lexing.lexeme lexbuf) } + | lvar { LVAR (curr lexbuf, Lexing.lexeme lexbuf) } + | _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf)) } + | eof { EOF } + +and read_string buf = + parse + | '"' { let lend = curr lexbuf in + let loc = merge (!l_start_string) lend in + STRING (loc, Buffer.contents buf) } + | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } + | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } + | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } + | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } + | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } + | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } + | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } + | [^ '"' '\\']+ + { Buffer.add_string buf (Lexing.lexeme lexbuf); + read_string buf lexbuf + } + | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } + | eof { raise (SyntaxError ("String is not terminated")) } + +and read_comment = + parse + | newline { new_line lexbuf; read lexbuf } + | eof { EOF } + | _ { read_comment lexbuf } diff --git a/wislfp/lib/ParserAndCompiler/WParser.mly b/wislfp/lib/ParserAndCompiler/WParser.mly new file mode 100644 index 000000000..bde7d9d99 --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/WParser.mly @@ -0,0 +1,696 @@ +%token EOF + +(* key words *) +%token TRUE FALSE NULL WHILE IF ELSE SKIP NEW DELETE PAR +%token FUNCTION RETURN PREDICATE LEMMA +%token INVARIANT FOLD UNFOLD NOUNFOLD APPLY ASSERT EXIST FORALL +%token STATEMENT WITH VARIANT PROOF +%token SPEC + +(* punctuation *) +%token COLON /* : */ +%token SEMICOLON /* ; */ +%token COMMA /* , */ +%token DOT /* . */ +%token ASSIGN /* := */ +%token RCBRACE /* } */ +%token LCBRACE /* { */ +%token LBRACE /* ( */ +%token RBRACE /* ) */ +%token LBRACK /* [ */ +%token RBRACK /* ] */ +%token LOGOPEN /* [[ */ +%token LOGCLOSE /* ]] */ +%token SETOPEN /* -{ */ +%token SETCLOSE /* }- */ +%token VDASH /* |- */ + +(* types *) +%token TLIST +%token TINT +%token TBOOL +%token TFLOAT + +(* names *) +%token IDENTIFIER + +(* values *) +%token INTEGER +%token FLOAT +%token STRING + +(* Binary operators *) +%token EQUAL /* = */ +%token LESSTHAN /* < */ +%token FLESSTHAN /* f< */ +%token GREATERTHAN /* > */ +%token FGREATERTHAN /* f> */ +%token LESSEQUAL /* <= */ +%token FLESSEQUAL /* f<= */ +%token GREATEREQUAL /* => */ +%token FGREATEREQUAL /* f=> */ +%token PLUS /* + */ +%token FPLUS /* f+ */ +%token MINUS /* - */ +%token FMINUS /* f- */ +%token TIMES /* * */ +%token FTIMES /* f* */ +%token DIV /* / */ +%token FDIV /* f/ */ +%token MOD /* % */ +%token FMOD /* f% */ +%token AND /* && */ +%token OR /* || */ +%token NEQ /* != */ +%token LSTCONS /* :: */ +%token LSTCAT /* @ */ +%token LSTNTH /* lnth */ + +(* Unary operators *) +%token NOT HEAD TAIL REV LEN SUB + +(* Logic Binary *) +%token ARROW /* -> */ +%token BLOCK_ARROW /* -b-> */ +%token LAND /* /\ */ +%token LOR /* \/ */ +%token LEQ /* == */ +%token LLESS /* <# */ +%token FLLESS /* f<# */ +%token LLESSEQ /* <=# */ +%token FLLESSEQ /* f<=# */ +%token LGREATER /* ># */ +%token FLGREATER /* f># */ +%token LGREATEREQ /* >=# */ +%token FLGREATEREQ /* f>=# */ + +(* Logic *) +%token EMP LTRUE LFALSE LSTNIL LNOT +%token LVAR + +(* Precedence *) +%left LOR +%left LAND separating_conjunction +%nonassoc LEQ LLESS FLLESS LLESSEQ FLLESSEQ LGREATER FLGREATER LGREATEREQ FLGREATEREQ +%nonassoc LNOT +%left OR +%left AND +%nonassoc EQUAL NEQ +%nonassoc LESSTHAN FLESSTHAN LESSEQUAL FLESSEQUAL GREATERTHAN FGREATERTHAN GREATEREQUAL FGREATEREQUAL +%nonassoc LSTCONS +%left LSTCAT +%left PLUS FPLUS MINUS FMINUS +%left TIMES FTIMES DIV FDIV MOD + +%nonassoc binop_prec +%nonassoc unop_prec + +(* Types and start *) +%start prog +%start assert_only + +%type definitions +%type fct_with_specs +%type fct +%type predicate +%type lemma +%type var_list +%type statement_list_and_return +%type statement_list +%type expression +%type expr_list +%type logic_command +%type logic_assertion +%type value_with_loc +%type unop_with_loc +%type binop +%type variant_def +%type with_variant_def +%type proof_def +%type <(string * WType.t option) * bool> pred_param_ins +%type bindings_with_loc +%type logic_pure_formula +%type logic_expression +%type logic_binop +%type logic_value_with_loc +%% + +prog: + | fcp = definitions; EOF { + let (fc, preds, lemmas) = fcp in + WProg.{ lemmas = lemmas; predicates = preds; context = fc } } + +assert_only: + | la = logic_assertion; EOF { la } + +definitions: + | (* empty *) { ([], [], []) } + | fpdcl = definitions; p = predicate + { let (fs, ps,ls) = fpdcl in + (fs, p::ps, ls) } + | fpdcl = definitions; l = lemma + { let (fs, ps, ls) = fpdcl in + (fs, ps, l::ls) } + | fpdcl = definitions; f = fct_with_specs + { let (fs, ps, ls) = fpdcl in + (f::fs, ps, ls) } + +spec_bindings: +| lstart = LBRACK; SPEC; spec_name = IDENTIFIER; COLON; vs_with_loc = separated_list(COMMA, LVAR); RBRACK + { let (_, variables) = List.split vs_with_loc in + let (_, spec_name) = spec_name in + (lstart, spec_name, variables) } + +fct_with_specs: + | lstart = LCBRACE; pre = logic_assertion; RCBRACE; variant = option(with_variant_def); f = fct; LCBRACE; + post = logic_assertion; lend = RCBRACE + { let loc = CodeLoc.merge lstart lend in + WFun.add_spec f pre post variant loc } + | bindings = spec_bindings; LCBRACE; pre = logic_assertion; RCBRACE; variant = option(with_variant_def); f = fct; LCBRACE; + post = logic_assertion; lend = RCBRACE + { let lstart, spec_name, lvars = bindings in + let existentials = Some (spec_name, lvars) in + let loc = CodeLoc.merge lstart lend in + WFun.add_spec ?existentials f pre post variant loc } + | f = fct { f } + +fct: + | lstart = FUNCTION; lf = IDENTIFIER; LBRACE; params = var_list; RBRACE; (* block_start = *) LCBRACE; + stmtsandret = statement_list_and_return; lend = RCBRACE; + { let (_, f) = lf in + let (stmts, e) = stmtsandret in + (* let block_loc = CodeLoc.merge block_start lend in + let () = WStmt.check_consistency stmts block_loc in *) + let floc = CodeLoc.merge lstart lend in + let fid = Generators.gen_id () in + WFun.{ + name = f; + params = params; + body = stmts; + return_expr = e; + spec = None; + floc; + fid; + is_loop_body = false; + } } + + +var_list: + lvl = separated_list(COMMA, IDENTIFIER) + { let (_, vl) = List.split lvl (* remove locations because not needed here *) + in vl } + + +statement_list_and_return: + | RETURN; e = expression { ([], e) } + | sm = statement; SEMICOLON; sle = statement_list_and_return + { let (sl, e) = sle in (sm::sl, e) } + +statement_list: + | sl = separated_nonempty_list(SEMICOLON, statement) { sl } + + +/* not useful at the moment */ +/* +logic_cmds: + | LCMD; lcmds = separated_list(SEMICOLON, logic_command); RCBRACE { lcmds } + */ + +logical_binding: + | LBRACE; lhs = LVAR; COLON; rhs = LVAR; RBRACE + { let (_, lhs) = lhs in + let (loc, rhs) = rhs in + let bare_lexpr = WLExpr.LVar rhs in + let expr = WLExpr.make bare_lexpr loc in + (lhs, expr) + } + +passed_logical_bindings: + | LBRACK; spec_name = IDENTIFIER; COLON; bindings = separated_nonempty_list(COMMA, logical_binding); lend = RBRACK + { let (_, spec_name) = spec_name in + (spec_name, bindings, lend) + } + +function_call: + | lx = IDENTIFIER; ASSIGN; lf = IDENTIFIER; LBRACE; params = expr_list; lend = RBRACE + { let (lstart, x) = lx in + let (_, f) = lf in + let bare_stmt = WStmt.FunCall (x, f, params, None) in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc + } + | lx = IDENTIFIER; ASSIGN; lf = IDENTIFIER; LBRACE; params = expr_list; RBRACE; bindings = passed_logical_bindings + { let (lstart, x) = lx in + let (_, f) = lf in + let (spec_name, bindings, lend) = bindings in + let bare_stmt = WStmt.FunCall (x, f, params, Some (spec_name, bindings)) in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc + } + +function_call_list: + sl = separated_nonempty_list(SEMICOLON, function_call) { sl } + + +statement: + | loc = SKIP { WStmt.make WStmt.Skip loc } + | lx = IDENTIFIER; ASSIGN; e = expression + { let (lstart, x) = lx in + let bare_stmt = WStmt.VarAssign (x, e) in + let lend = WExpr.get_loc e in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc } + | lx = IDENTIFIER; ASSIGN; NEW; LBRACE; ln = INTEGER; lend = RBRACE + { let (lstart, x) = lx in + let (_, i) = ln in + let bare_stmt = WStmt.New (x, i) in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc } + | lstart = DELETE; LBRACE; e = expression; lend = RBRACE; + { let bare_stmt = WStmt.Dispose e in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc } + | lx = IDENTIFIER; ASSIGN; LBRACK; e = expression; lend = RBRACK + { let (lstart, x) = lx in + let bare_stmt = WStmt.Lookup (x, e) in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc } + | lstart = LBRACK; e1 = expression; RBRACK; ASSIGN; e2 = expression + {let bare_stmt = WStmt.Update (e1, e2) in + let lend = WExpr.get_loc e2 in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc + } + | s = function_call { s } + | lstart = PAR; LCBRACE; fs = function_call_list; lend = RCBRACE; + { + let bare_stmt = WStmt.Par (fs) in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc + } + | lstart = WHILE; LBRACE; b = expression; lend = RBRACE; + (* block_start = *) LCBRACE; sl = statement_list; (* block_end = *) RCBRACE + { (* let block_loc = CodeLoc.merge block_start block_end in + let () = WStmt.check_consistency sl block_loc in *) + let bare_stmt = WStmt.While (b, sl) in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc + } + | lstart = IF; LBRACE; b = expression; lend = RBRACE; + (* block_1_start = *) LCBRACE; sl1 = statement_list; (* block_1_end = *) RCBRACE; + (* block_2_start = *) ELSE; LCBRACE; sl2 = statement_list; (* block_2_end = *) RCBRACE + { + (* let block_1_loc = CodeLoc.merge block_1_start block_1_end in + let () = WStmt.check_consistency sl1 block_1_loc in + let block_2_loc = CodeLoc.merge block_2_start block_2_end in + let () = WStmt.check_consistency sl2 block_2_loc in *) + let bare_stmt = WStmt.If (b, sl1, sl2) in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc + } + | lstart = LOGOPEN; lc = logic_command; lend = LOGCLOSE + { let bare_stmt = WStmt.Logic lc in + let loc = CodeLoc.merge lstart lend in + WStmt.make bare_stmt loc } + + +expr_list: + el = separated_list(COMMA, expression) { el } + +expression: + | lstart = LBRACE; e = expression; lend = RBRACE + { let bare_expr = WExpr.get e in + let loc = CodeLoc.merge lstart lend in + WExpr.make bare_expr loc } + | lv = value_with_loc + { let (loc, v) = lv in + let bare_expr = WExpr.Val v in + WExpr.make bare_expr loc } + | lx = IDENTIFIER + { let (loc, x) = lx in + let bare_expr = WExpr.Var x in + WExpr.make bare_expr loc } + | e1 = expression; b = binop; e2 = expression + { let bare_expr = WExpr.BinOp (e1, b, e2) in + let lstart, lend = WExpr.get_loc e1, WExpr.get_loc e2 in + let loc = CodeLoc.merge lstart lend in + WExpr.make bare_expr loc } %prec binop_prec + | lu = unop_with_loc; e = expression + { let (lstart, u) = lu in + let bare_expr = WExpr.UnOp (u, e) in + let lend = WExpr.get_loc e in + let loc = CodeLoc.merge lstart lend in + WExpr.make bare_expr loc } %prec unop_prec + +binop: + | EQUAL { WBinOp.EQUAL } + | LESSTHAN { WBinOp.LESSTHAN } + | FLESSTHAN { WBinOp.FLESSTHAN } + | GREATERTHAN { WBinOp.GREATERTHAN } + | FGREATERTHAN { WBinOp.FGREATERTHAN } + | LESSEQUAL { WBinOp.LESSEQUAL } + | FLESSEQUAL { WBinOp.FLESSEQUAL } + | GREATEREQUAL { WBinOp.GREATEREQUAL } + | FGREATEREQUAL { WBinOp.FGREATEREQUAL } + | PLUS { WBinOp.PLUS } + | FPLUS { WBinOp.FPLUS } + | MINUS { WBinOp.MINUS } + | FMINUS { WBinOp.FMINUS } + | TIMES { WBinOp.TIMES } + | FTIMES { WBinOp.FTIMES } + | DIV { WBinOp.DIV } + | FDIV { WBinOp.FDIV } + | MOD { WBinOp.MOD } + | FMOD { WBinOp.FMOD } + | AND { WBinOp.AND } + | OR { WBinOp.OR } + | NEQ { WBinOp.NEQ } + +unop_with_loc: + | loc = NOT { (loc, WUnOp.NOT) } + | loc = LEN { (loc, WUnOp.LEN) } + | loc = HEAD { (loc, WUnOp.HEAD) } + | loc = REV { (loc, WUnOp.REV) } + | loc = TAIL { (loc, WUnOp.TAIL) } + +value_with_loc: + | lf = FLOAT { let (loc, f) = lf in (loc, WVal.Float f)} + | lf = INTEGER { let (loc, f) = lf in (loc, WVal.Int f) } + | ls = STRING { let (loc, s) = ls in (loc, WVal.Str s) } + | loc = TRUE { (loc, WVal.Bool true) } + | loc = FALSE { (loc, WVal.Bool false) } + | loc = NULL { (loc, WVal.Null) } + + +(* Logic stuff *) + +lemma: + | lstart = LEMMA; lname = IDENTIFIER; LCBRACE; + STATEMENT; COLON; + FORALL lemma_params = var_list; DOT; + lemma_hypothesis = logic_assertion; VDASH; lemma_conclusion = logic_assertion; + lemma_variant = option(variant_def); + lemma_proof = option(proof_def); + lend = RCBRACE + { let (_, lemma_name) = lname in + let lemma_loc = CodeLoc.merge lstart lend in + let lemma_id = Generators.gen_id () in + WLemma.{ + lemma_name; + lemma_params; + lemma_proof; + lemma_variant; + lemma_hypothesis; + lemma_conclusion; + lemma_loc; + lemma_id; + } } + +variant_def: + | VARIANT; COLON; e = logic_expression { e } + +with_variant_def: + | WITH; variant = variant_def { variant } + +proof_def: + | PROOF; COLON; pr = separated_nonempty_list(SEMICOLON, logic_command) + { pr } + +predicate: + | lstart = PREDICATE; pred_nounfold = option(NOUNFOLD); lpname = IDENTIFIER; LBRACE; params_ins = separated_list(COMMA, pred_param_ins); RBRACE; LCBRACE; + pred_definitions = separated_nonempty_list(SEMICOLON, logic_assertion); + lend = RCBRACE; + { let (_, pred_name) = lpname in + let (pred_params, ins) : (string * WType.t option) list * bool list = List.split params_ins in + (* ins looks like [true, false, true] *) + let ins = List.mapi (fun i is_in -> if is_in then Some i else None) ins in + (* ins looks like [Some 0, None, Some 2] *) + let ins = List.filter Option.is_some ins in + (* ins looks like [Some 0, Some 2] *) + let ins = List.map Option.get ins in + (* ins looks like [0, 2] *) + let pred_ins = if (List.length ins) > 0 then ins else (List.mapi (fun i _ -> i) pred_params) in + (* if ins is empty then everything is an in *) + let pred_nounfold = (pred_nounfold <> None) in + let pred_loc = CodeLoc.merge lstart lend in + let pred_id = Generators.gen_id () in + WPred.{ + pred_name; + pred_params; + pred_definitions; + pred_ins; + pred_nounfold; + pred_loc; + pred_id; + } } + +type_target: + | TLIST { WType.WList } + | TINT { WType.WInt } + | TBOOL { WType.WBool } + | TFLOAT { WType.WFloat } + +pred_param_ins: + | inp = option(PLUS); lx = IDENTIFIER; option(preceded(COLON, type_target)) + { let (_, x) = lx in + let isin = Option.fold ~some:(fun _ -> true) ~none:false inp in + ((x, $3), isin) } + + +logic_command: + | lstart = FOLD; lpr = IDENTIFIER; + LBRACE; params = separated_list(COMMA, logic_expression); lend = RBRACE + { let (_, pr) = lpr in + let bare_lcmd = WLCmd.Fold (pr, params) in + let loc = CodeLoc.merge lstart lend in + WLCmd.make bare_lcmd loc } + | lstart = UNFOLD; lpr = IDENTIFIER; + LBRACE; params = separated_list(COMMA, logic_expression); lend = RBRACE + { let (_, pr) = lpr in + let bare_lcmd = WLCmd.Unfold (pr, params) in + let loc = CodeLoc.merge lstart lend in + WLCmd.make bare_lcmd loc } + | lstart = APPLY; lbopt = option(bindings_with_loc); lname = IDENTIFIER; LBRACE; + params = separated_list(COMMA, logic_expression); lend = RBRACE + { let (_, name) = lname in + let bindings = match lbopt with None -> [] | Some (_, bs) -> bs in + let bare_lcmd = WLCmd.ApplyLem (name, params, bindings) in + let loc = CodeLoc.merge lstart lend in + WLCmd.make bare_lcmd loc } + | lstart = IF; LBRACE; g = logic_expression; lend = RBRACE; + LCBRACE; thencmds = separated_list(SEMICOLON, logic_command); RCBRACE; + ELSE; LCBRACE; elsecmds = separated_list(SEMICOLON, logic_command); RCBRACE + { let bare_lcmd = WLCmd.LogicIf (g, thencmds, elsecmds) in + let loc = CodeLoc.merge lstart lend in + WLCmd.make bare_lcmd loc } + | lstart = IF; LBRACE; g = logic_expression; lend = RBRACE; + LCBRACE; thencmds = separated_list(SEMICOLON, logic_command); RCBRACE; + { let bare_lcmd = WLCmd.LogicIf (g, thencmds, []) in + let loc = CodeLoc.merge lstart lend in + WLCmd.make bare_lcmd loc } + | lstart = ASSERT; lbopt = option(bindings_with_loc); a = logic_assertion; + { let lend = WLAssert.get_loc a in + let (_, b) = Option.value ~default:(lstart, []) lbopt in + let loc = CodeLoc.merge lstart lend in + let bare_lcmd = WLCmd.Assert (a, b) in + WLCmd.make bare_lcmd loc } + | lstart = INVARIANT; lbopt = option(bindings_with_loc); a = logic_assertion; variant = option(with_variant_def); + { let lend = WLAssert.get_loc a in + let (_, b) = Option.value ~default:(lstart, []) lbopt in + let loc = CodeLoc.merge lstart lend in + let bare_lcmd = WLCmd.Invariant (a, b, variant) in + WLCmd.make bare_lcmd loc } + +bindings_with_loc: + | lstart = LCBRACE; EXIST; COLON; lvll = separated_list(COMMA, lvar_or_pvar); lend = RCBRACE; + { let (_, lvl) = List.split lvll in + let loc = CodeLoc.merge lstart lend in + (loc, lvl) } + +lvar_or_pvar: + | x = IDENTIFIER { x } + | lx = LVAR { lx } + +logic_expression_with_permission: + | LBRACE; perm = logic_expression; COLON; expr = logic_expression; RBRACE; + { (Some perm, expr) } + | expr = logic_expression; + { (None, expr) } + +logic_assertion: + | lstart = LBRACE; la = logic_assertion; lend = RBRACE; + { let bare_assert = WLAssert.get la in + let loc = CodeLoc.merge lstart lend in + WLAssert.make bare_assert loc } + | lpr = IDENTIFIER; LBRACE; params = separated_list(COMMA, logic_expression); lend = RBRACE + { let (lstart, pr) = lpr in + let bare_assert = WLAssert.LPred (pr, params) in + let loc = CodeLoc.merge lstart lend in + WLAssert.make bare_assert loc } + | loc = EMP + { let bare_assert = WLAssert.LEmp in + WLAssert.make bare_assert loc } + | la1 = logic_assertion; TIMES; la2 = logic_assertion + { let bare_assert = WLAssert.LStar (la1, la2) in + let lstart, lend = WLAssert.get_loc la1, WLAssert.get_loc la2 in + let loc = CodeLoc.merge lstart lend in + WLAssert.make bare_assert loc } %prec separating_conjunction + | le1 = logic_expression; ARROW; le2 = separated_nonempty_list(COMMA, logic_expression_with_permission) + { let rec get_lend lel = + match lel with + | [] -> failwith "Nonempty list cannot be empty" + | [(_, a)] -> WLExpr.get_loc a + | _::r -> get_lend r + in + let bare_assert = WLAssert.LPointsTo (le1, le2) in + let lstart = WLExpr.get_loc le1 in + let lend = get_lend le2 in + let loc = CodeLoc.merge lstart lend in + WLAssert.make bare_assert loc } + | le1 = logic_expression; BLOCK_ARROW; le2 = separated_nonempty_list(COMMA, logic_expression_with_permission) + { let rec get_lend lel = + match lel with + | [] -> failwith "Nonempty list cannot be empty" + | [(_, a)] -> WLExpr.get_loc a + | _::r -> get_lend r + in + let bare_assert = WLAssert.LBlockPointsTo (le1, le2) in + let lstart = WLExpr.get_loc le1 in + let lend = get_lend le2 in + let loc = CodeLoc.merge lstart lend in + WLAssert.make bare_assert loc } + | formula = logic_pure_formula + { let bare_assert = WLAssert.LPure formula in + let loc = WLFormula.get_loc formula in + WLAssert.make bare_assert loc } + +logic_pure_formula: + | lstart = LBRACE; la = logic_pure_formula; lend = RBRACE; + { let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.get la in + WLFormula.make bare_form loc } + | le1 = logic_expression; LEQ; le2 = logic_expression + { let lstart, lend = WLExpr.get_loc le1, WLExpr.get_loc le2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.LEq (le1, le2) in + WLFormula.make bare_form loc } + | le1 = logic_expression; LLESS; le2 = logic_expression + { let lstart, lend = WLExpr.get_loc le1, WLExpr.get_loc le2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.LLess (le1, le2) in + WLFormula.make bare_form loc } + | le1 = logic_expression; FLLESS; le2 = logic_expression + { let lstart, lend = WLExpr.get_loc le1, WLExpr.get_loc le2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.FLLess (le1, le2) in + WLFormula.make bare_form loc } + | le1 = logic_expression; LLESSEQ; le2 = logic_expression + { let lstart, lend = WLExpr.get_loc le1, WLExpr.get_loc le2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.LLessEq (le1, le2) in + WLFormula.make bare_form loc } + | le1 = logic_expression; FLLESSEQ; le2 = logic_expression + { let lstart, lend = WLExpr.get_loc le1, WLExpr.get_loc le2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.FLLessEq (le1, le2) in + WLFormula.make bare_form loc } + | le1 = logic_expression; LGREATEREQ; le2 = logic_expression + { let lstart, lend = WLExpr.get_loc le1, WLExpr.get_loc le2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.LGreaterEq (le1, le2) in + WLFormula.make bare_form loc } + | le1 = logic_expression; FLGREATEREQ; le2 = logic_expression + { let lstart, lend = WLExpr.get_loc le1, WLExpr.get_loc le2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.FLGreaterEq (le1, le2) in + WLFormula.make bare_form loc } + | le1 = logic_expression; LGREATER; le2 = logic_expression + { let lstart, lend = WLExpr.get_loc le1, WLExpr.get_loc le2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.LGreater (le1, le2) in + WLFormula.make bare_form loc } + | le1 = logic_expression; FLGREATER; le2 = logic_expression + { let lstart, lend = WLExpr.get_loc le1, WLExpr.get_loc le2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.FLGreater (le1, le2) in + WLFormula.make bare_form loc } + | lstart = LNOT; la = logic_pure_formula + { let bare_form = WLFormula.LNot la in + let lend = WLFormula.get_loc la in + let loc = CodeLoc.merge lstart lend in + WLFormula.make bare_form loc } + | la1 = logic_pure_formula; LAND; la2 = logic_pure_formula + { let lstart, lend = WLFormula.get_loc la1, WLFormula.get_loc la2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.LAnd (la1, la2) in + WLFormula.make bare_form loc } + | la1 = logic_pure_formula; LOR; la2 = logic_pure_formula + { let lstart, lend = WLFormula.get_loc la1, WLFormula.get_loc la2 in + let loc = CodeLoc.merge lstart lend in + let bare_form = WLFormula.LOr (la1, la2) in + WLFormula.make bare_form loc } + | loc = LTRUE + { let bare_form = WLFormula.LTrue in + WLFormula.make bare_form loc } + | loc = LFALSE + { let bare_form = WLFormula.LFalse in + WLFormula.make bare_form loc } + + +logic_expression: + | lstart = LBRACE; le = logic_expression; lend = RBRACE + { let loc = CodeLoc.merge lstart lend in + let bare_lexpr = WLExpr.get le in + WLExpr.make bare_lexpr loc } + | lv = logic_value_with_loc + { let (loc, v) = lv in + let bare_lexpr = WLExpr.LVal v in + WLExpr.make bare_lexpr loc } + | lx = IDENTIFIER { + let (loc, x) = lx in + let bare_lexpr = WLExpr.PVar x in + WLExpr.make bare_lexpr loc } + | llx = LVAR + { let (loc, lx) = llx in + let bare_lexpr = WLExpr.LVar lx in + WLExpr.make bare_lexpr loc } + | e1 = logic_expression; b = logic_binop; e2 = logic_expression + { let bare_lexpr = WLExpr.LBinOp (e1, b, e2) in + let lstart, lend = WLExpr.get_loc e1, WLExpr.get_loc e2 in + let loc = CodeLoc.merge lstart lend in + WLExpr.make bare_lexpr loc } %prec binop_prec + | lstart = SUB; LBRACE; e1 = logic_expression; COMMA; e2 = logic_expression; COMMA; e3 = logic_expression; lend = RBRACE { + let loc = CodeLoc.merge lstart lend in + let bare_lexpr = WLExpr.LLSub(e1, e2, e3) in + WLExpr.make bare_lexpr loc } + | lu = unop_with_loc; e = logic_expression + { let (lstart, u) = lu in + let lend = WLExpr.get_loc e in + let loc = CodeLoc.merge lstart lend in + let bare_lexpr = WLExpr.LUnOp (u, e) in + WLExpr.make bare_lexpr loc } %prec unop_prec + | lstart = LBRACK; l = separated_list(COMMA, logic_expression); lend = RBRACK + { let loc = CodeLoc.merge lstart lend in + let bare_lexpr = WLExpr.LEList l in + WLExpr.make bare_lexpr loc } + | lstart = SETOPEN; l = separated_list(COMMA, logic_expression); lend = SETCLOSE + { let loc = CodeLoc.merge lstart lend in + let bare_lexpr = WLExpr.LESet l in + WLExpr.make bare_lexpr loc } + + +(* We also have lists in the logic *) +logic_binop: + | b = binop { b } + | LSTCONS { WBinOp.LSTCONS } + | LSTCAT { WBinOp.LSTCAT } + | LSTNTH { WBinOp.LSTNTH } + +logic_value_with_loc: + | lv = value_with_loc { lv } + | loc = LSTNIL + { (loc, WVal.VList []) } + /* | lstart = LBRACK; lvl = separated_list(COMMA, logic_value_with_loc); lend = RBRACK + { let (_, vl) = List.split lvl in + let loc = CodeLoc.merge lstart lend in + (loc, WVal.VList vl) } */ diff --git a/wislfp/lib/ParserAndCompiler/dune b/wislfp/lib/ParserAndCompiler/dune new file mode 100644 index 000000000..ce02919da --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/dune @@ -0,0 +1,13 @@ +(ocamllex + (modules WLexer)) + +(menhir + (modules WParser) + (flags --explain)) + +(library + (name pwParserAndCompiler) + (libraries gillian pwSyntax pwUtils pwSemantics) + (preprocess + (pps ppx_deriving.std ppx_deriving_yojson)) + (flags :standard -open PwSyntax -open PwUtils -open PwSemantics)) diff --git a/wislfp/lib/ParserAndCompiler/pwParserAndCompiler.ml b/wislfp/lib/ParserAndCompiler/pwParserAndCompiler.ml new file mode 100644 index 000000000..8f0a5d383 --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/pwParserAndCompiler.ml @@ -0,0 +1,60 @@ +open Lexing +open WLexer + +type init_data = unit +type err = unit +type tl_ast = WProg.t + +module Annot = WAnnot + +let pp_err _ () = () + +let parse_with_error token lexbuf = + try token read lexbuf with + | SyntaxError message -> failwith ("SYNTAX ERROR" ^ message) + | WParser.Error -> + let range = CodeLoc.curr lexbuf in + let message = + Printf.sprintf "unexpected token : %s at loc %s" (Lexing.lexeme lexbuf) + (CodeLoc.str range) + in + failwith ("PARSER ERROR : " ^ message) + +let parse_file file = + let inx = open_in file in + let lexbuf = Lexing.from_channel inx in + let () = lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = file } in + let wprog = parse_with_error WParser.prog lexbuf in + let () = close_in inx in + wprog + +let compile = Wisl2Gil.compile + +let create_compilation_result path prog wprog = + let open Command_line.ParserAndCompiler in + let open IncrementalAnalysis in + let source_files = SourceFiles.make () in + let () = SourceFiles.add_source_file source_files ~path in + let gil_path = Filename.chop_extension path ^ ".gil" in + { + gil_progs = [ (gil_path, prog) ]; + source_files; + tl_ast = wprog; + init_data = (); + } + +let parse_and_compile_files files = + let f files = + let path = List.hd files in + let wprog = parse_file path in + Ok (create_compilation_result path (compile ~filepath:path wprog) wprog) + in + Logging.Phase.with_normal ~title:"Program parsing and compilation" (fun () -> + f files) + +let other_imports = [] +let initialize _ = () +let env_var_import_path = Some WConfig.import_env_var + +module TargetLangOptions = + Gillian.Command_line.ParserAndCompiler.Dummy.TargetLangOptions diff --git a/wislfp/lib/ParserAndCompiler/pwParserAndCompiler.mli b/wislfp/lib/ParserAndCompiler/pwParserAndCompiler.mli new file mode 100644 index 000000000..1894e06ef --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/pwParserAndCompiler.mli @@ -0,0 +1,5 @@ +include + Gillian.Command_line.ParserAndCompiler.S + with type tl_ast = WProg.t + and type init_data = unit + and module Annot = WAnnot diff --git a/wislfp/lib/ParserAndCompiler/wisl2Gil.ml b/wislfp/lib/ParserAndCompiler/wisl2Gil.ml new file mode 100644 index 000000000..9edd627f9 --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/wisl2Gil.ml @@ -0,0 +1,1180 @@ +(* TODO: Before merging, this has to be entirely documented. Step by step, how does the compilation work. + More exactly, the compilation of logical expr and expr, as well a stmts should be detailed. *) + +open WislConstants.Prefix +open WislConstants.InternalProcs +open WislConstants.InternalPreds +open Gillian.Gil_syntax +module SS = Gillian.Utils.Containers.SS + +(* Some utility functions *) + +let rec list_split_3 l = + match l with + | [] -> ([], [], []) + | (a, b, c) :: r -> + let la, lb, lc = list_split_3 r in + (a :: la, b :: lb, c :: lc) + +(* Compiler functions *) +let compile_type t = + WType.( + match t with + | WList -> Some Type.ListType + | WNull -> Some Type.NullType + | WBool -> Some Type.BooleanType + | WString -> Some Type.StringType + | WPtr -> Some Type.ObjectType + | WInt -> Some Type.IntType + | WFloat -> Some Type.NumberType + | WSet -> Some Type.SetType + | WAny -> None) + +let compile_binop b = + WBinOp.( + match b with + | EQUAL -> BinOp.Equal + | LESSTHAN -> BinOp.ILessThan + | FLESSTHAN -> BinOp.FLessThan + | LESSEQUAL -> BinOp.ILessThanEqual + | FLESSEQUAL -> BinOp.FLessThanEqual + | PLUS -> BinOp.IPlus + | FPLUS -> BinOp.FPlus + | MINUS -> BinOp.IMinus + | FMINUS -> BinOp.FMinus + | TIMES -> BinOp.ITimes + | FTIMES -> BinOp.FTimes + | DIV -> BinOp.IDiv + | FDIV -> BinOp.FDiv + | MOD -> BinOp.IMod + | FMOD -> BinOp.FMod + | AND -> BinOp.BAnd + | OR -> BinOp.BOr + | LSTNTH -> BinOp.LstNth + (* operators that do not exist in gil are compiled separately *) + | _ -> + failwith + (Format.asprintf "compile_binop should not be used to compile %a" pp b)) + +let compile_unop u = + WUnOp.( + match u with + | NOT -> UnOp.UNot + | LEN -> UnOp.LstLen + | HEAD -> UnOp.Car + | TAIL -> UnOp.Cdr + | REV -> UnOp.LstRev) + +let rec compile_val v = + let open WVal in + match v with + | Bool b -> Literal.Bool b + | Null -> Literal.Null + | Int n -> Literal.Int (Z.of_int n) + | Float x -> Literal.Num x + | Str s -> Literal.String s + | VList l -> Literal.LList (List.map compile_val l) + +let rec compile_expr ?(fname = "main") ?(is_loop_prefix = false) expr : + (WAnnot.t * string option * string Cmd.t) list * Expr.t = + let gen_str = Generators.gen_str fname in + let compile_expr = compile_expr ~fname ~is_loop_prefix in + let expr_of_string s = Expr.Lit (Literal.String s) in + let expr_fname_of_binop b = + WBinOp.( + match b with + | PLUS -> expr_of_string internal_add + | MINUS -> expr_of_string internal_minus + | LESSEQUAL -> expr_of_string internal_leq + | LESSTHAN -> expr_of_string internal_lt + | GREATEREQUAL -> expr_of_string internal_geq + | GREATERTHAN -> expr_of_string internal_gt + | _ -> + failwith + (Format.asprintf + "Binop %a does not correspond to an internal function" WBinOp.pp + b)) + in + let is_internal_func = + WBinOp.( + function + | PLUS | MINUS | LESSEQUAL | LESSTHAN | GREATEREQUAL | GREATERTHAN -> true + | _ -> false) + in + let stmt_kind = if is_loop_prefix then WAnnot.LoopPrefix else WAnnot.Single in + let open WExpr in + match get expr with + | Val v -> ([], Expr.Lit (compile_val v)) + | Var "ret" -> + failwith + (Format.asprintf + "ret (at location %s) is the special name used for the return\n\ + \ value in the logic. It cannot be used \ + as a variable name" + (CodeLoc.str (get_loc expr))) + | Var x -> ([], Expr.PVar x) + | BinOp (e1, WBinOp.LSTCONS, e2) -> + let cmdl1, comp_expr1 = compile_expr e1 in + let cmdl2, comp_expr2 = compile_expr e2 in + let expr = Expr.NOp (LstCat, [ EList [ comp_expr1 ]; comp_expr2 ]) in + (cmdl1 @ cmdl2, expr) + | BinOp (e1, WBinOp.LSTCAT, e2) -> + let cmdl1, comp_expr1 = compile_expr e1 in + let cmdl2, comp_expr2 = compile_expr e2 in + let expr = Expr.NOp (LstCat, [ comp_expr1; comp_expr2 ]) in + (cmdl1 @ cmdl2, expr) + | BinOp (e1, b, e2) when is_internal_func b -> + (* Operator corresponds to pointer arithmetics *) + let call_var = gen_str gvar in + let internal_func = expr_fname_of_binop b in + let cmdl1, comp_expr1 = compile_expr e1 in + let cmdl2, comp_expr2 = compile_expr e2 in + let call_i_plus = + Cmd.call + (call_var, internal_func, [ comp_expr1; comp_expr2 ], None, None) + in + ( cmdl1 @ cmdl2 + @ [ + ( WAnnot.make ~origin_id:(get_id expr) + ~origin_loc:(CodeLoc.to_location (get_loc expr)) + ~stmt_kind (), + None, + call_i_plus ); + ], + Expr.PVar call_var ) + | BinOp (e1, b, e2) -> + (* Operator cannot do pointer arithmetics *) + let cmdl1, comp_e1 = compile_expr e1 in + let cmdl2, comp_e2 = compile_expr e2 in + (cmdl1 @ cmdl2, Expr.BinOp (comp_e1, compile_binop b, comp_e2)) + | UnOp (u, e) -> + let cmdl, comp_expr = compile_expr e in + (cmdl, Expr.UnOp (compile_unop u, comp_expr)) + | List el -> + let cmds, comp_es = List.split (List.map compile_expr el) in + let cmds = List.concat cmds in + (cmds, Expr.EList comp_es) + +(* compile_lexpr : WLExpr.t -> (string list * Asrt.t list * Expr.t) + compiles a WLExpr into an output expression and a list of Global Assertions. + the string list contains the name of the variables that are generated. They are existentials. *) +let rec compile_lexpr ?(fname = "main") (lexpr : WLExpr.t) : + string list * Asrt.t list * Expr.t = + let gen_str = Generators.gen_str fname in + let compile_lexpr = compile_lexpr ~fname in + let expr_pname_of_binop b = + WBinOp.( + match b with + | PLUS -> internal_pred_add + | MINUS -> internal_pred_minus + | LESSEQUAL -> internal_pred_leq + | LESSTHAN -> internal_pred_lt + | GREATEREQUAL -> internal_pred_geq + | GREATERTHAN -> internal_pred_gt + | _ -> + failwith + (Format.asprintf + "Binop %a does not correspond to an internal function" WBinOp.pp + b)) + in + let is_internal_pred = + WBinOp.( + function + | PLUS | MINUS | LESSEQUAL | LESSTHAN | GREATEREQUAL | GREATERTHAN -> true + | _ -> false) + in + WLExpr.( + match get lexpr with + | LVal v -> ([], [], Expr.Lit (compile_val v)) + | PVar x -> ([], [], Expr.PVar x) + | LVar x -> ([], [], Expr.LVar x) + | LBinOp (e1, WBinOp.NEQ, e2) -> + let gvars1, asrtl1, comp_expr1 = compile_lexpr e1 in + let gvars2, asrtl2, comp_expr2 = compile_lexpr e2 in + let expr = + Expr.UnOp (UnOp.UNot, Expr.BinOp (comp_expr1, BinOp.Equal, comp_expr2)) + in + (gvars1 @ gvars2, asrtl1 @ asrtl2, expr) + | LBinOp (e1, b, e2) when is_internal_pred b -> + (* Operator corresponds to pointer arithmetics *) + let lout = gen_str sgvar in + let internal_pred = expr_pname_of_binop b in + let gvars1, asrtl1, comp_expr1 = compile_lexpr e1 in + let gvars2, asrtl2, comp_expr2 = compile_lexpr e2 in + let pred_i_plus = + Asrt.Pred (internal_pred, [ comp_expr1; comp_expr2; Expr.LVar lout ]) + in + ( gvars1 @ gvars2 @ [ lout ], + asrtl1 @ asrtl2 @ [ pred_i_plus ], + Expr.LVar lout ) + | LBinOp (e1, WBinOp.LSTCONS, e2) -> + let gvars1, asrt1, comp_e1 = compile_lexpr e1 in + let gvars2, asrt2, comp_e2 = compile_lexpr e2 in + let expr = Expr.NOp (LstCat, [ EList [ comp_e1 ]; comp_e2 ]) in + (gvars1 @ gvars2, asrt1 @ asrt2, expr) + | LBinOp (e1, WBinOp.LSTCAT, e2) -> + let gvars1, asrt1, comp_e1 = compile_lexpr e1 in + let gvars2, asrt2, comp_e2 = compile_lexpr e2 in + let expr = Expr.NOp (LstCat, [ comp_e1; comp_e2 ]) in + (gvars1 @ gvars2, asrt1 @ asrt2, expr) + | LBinOp (e1, b, e2) -> + (* Operator cannot do pointer arithmetics *) + let gvars1, asrt1, comp_e1 = compile_lexpr e1 in + let gvars2, asrt2, comp_e2 = compile_lexpr e2 in + ( gvars1 @ gvars2, + asrt1 @ asrt2, + Expr.BinOp (comp_e1, compile_binop b, comp_e2) ) + | LUnOp (u, e) -> + let gvars, asrt, comp_expr = compile_lexpr e in + (gvars, asrt, Expr.UnOp (compile_unop u, comp_expr)) + | LLSub (e1, e2, e3) -> + let gvars1, asrt1, comp_e1 = compile_lexpr e1 in + let gvars2, asrt2, comp_e2 = compile_lexpr e2 in + let gvars3, asrt3, comp_e3 = compile_lexpr e3 in + ( gvars1 @ gvars2 @ gvars3, + asrt1 @ asrt2 @ asrt3, + Expr.LstSub (comp_e1, comp_e2, comp_e3) ) + | LEList l -> + let gvars, asrtsl, comp_exprs = + list_split_3 (List.map compile_lexpr l) + in + (List.concat gvars, List.concat asrtsl, Expr.EList comp_exprs) + | LESet l -> + let gvars, asrtsl, comp_exprs = + list_split_3 (List.map compile_lexpr l) + in + (List.concat gvars, List.concat asrtsl, Expr.ESet comp_exprs)) + +(* TODO: compile_lformula should return also the list of created existentials *) +let rec compile_lformula ?(fname = "main") formula : Asrt.t list * Formula.t = + let gen_str = Generators.gen_str fname in + let compile_lformula = compile_lformula ~fname in + let compile_lexpr = compile_lexpr ~fname in + WLFormula.( + match get formula with + | LTrue -> ([], Formula.True) + | LFalse -> ([], Formula.False) + | LNot lf -> + let a1, c1 = compile_lformula lf in + (a1, Formula.Not c1) + | LAnd (lf1, lf2) -> + let a1, c1 = compile_lformula lf1 in + let a2, c2 = compile_lformula lf2 in + (a1 @ a2, Formula.And (c1, c2)) + | LOr (lf1, lf2) -> + let a1, c1 = compile_lformula lf1 in + let a2, c2 = compile_lformula lf2 in + (a1 @ a2, Formula.Or (c1, c2)) + | LEq (le1, le2) -> + let _, a1, c1 = compile_lexpr le1 in + let _, a2, c2 = compile_lexpr le2 in + (a1 @ a2, Formula.Eq (c1, c2)) + | LLess (le1, le2) -> + let _, a1, c1 = compile_lexpr le1 in + let _, a2, c2 = compile_lexpr le2 in + let expr_l_var_out = Expr.LVar (gen_str sgvar) in + let pred = Asrt.Pred (internal_pred_lt, [ c1; c2; expr_l_var_out ]) in + ( a1 @ a2 @ [ pred ], + Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + | FLLess (le1, le2) -> + let _, a1, c1 = compile_lexpr le1 in + let _, a2, c2 = compile_lexpr le2 in + (a1 @ a2, Formula.FLess (c1, c2)) + | LGreater (le1, le2) -> + let _, a1, c1 = compile_lexpr le1 in + let _, a2, c2 = compile_lexpr le2 in + let expr_l_var_out = Expr.LVar (gen_str sgvar) in + let pred = Asrt.Pred (internal_pred_gt, [ c1; c2; expr_l_var_out ]) in + ( a1 @ a2 @ [ pred ], + Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + | FLGreater (le1, le2) -> + let _, a1, c1 = compile_lexpr le1 in + let _, a2, c2 = compile_lexpr le2 in + (a1 @ a2, Formula.FLess (c2, c1)) + | LLessEq (le1, le2) -> + let _, a1, c1 = compile_lexpr le1 in + let _, a2, c2 = compile_lexpr le2 in + let expr_l_var_out = Expr.LVar (gen_str sgvar) in + let pred = Asrt.Pred (internal_pred_leq, [ c1; c2; expr_l_var_out ]) in + ( a1 @ a2 @ [ pred ], + Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + | FLLessEq (le1, le2) -> + let _, a1, c1 = compile_lexpr le1 in + let _, a2, c2 = compile_lexpr le2 in + (a1 @ a2, Formula.FLessEq (c1, c2)) + | LGreaterEq (le1, le2) -> + let _, a1, c1 = compile_lexpr le1 in + let _, a2, c2 = compile_lexpr le2 in + let expr_l_var_out = Expr.LVar (gen_str sgvar) in + let pred = Asrt.Pred (internal_pred_geq, [ c1; c2; expr_l_var_out ]) in + ( a1 @ a2 @ [ pred ], + Formula.Eq (expr_l_var_out, Expr.Lit (Literal.Bool true)) ) + | FLGreaterEq (le1, le2) -> + let _, a1, c1 = compile_lexpr le1 in + let _, a2, c2 = compile_lexpr le2 in + (a1 @ a2, Formula.FLessEq (c2, c1))) + +(* compile_lassert returns the compiled assertion + the list of generated existentials *) +let rec compile_lassert ?(fname = "main") asser : string list * Asrt.t = + let compile_lassert = compile_lassert ~fname in + let gen_str = Generators.gen_str fname in + let compile_lexpr = compile_lexpr ~fname in + let compile_lformula = compile_lformula ~fname in + let concat_star = List.fold_left (fun a1 a2 -> Asrt.Star (a1, a2)) in + let gil_add e k = + (* builds GIL expression that is e + k *) + let k_e = Expr.int k in + let open Expr.Infix in + e + k_e + in + (* compiles le1 -> lle, returns the assertion AND the list of existential variables generated *) + let rec compile_pointsto + ?(start = true) + ~(block : bool) + ?(ptr_opt = None) + ?(curr = 0) + (le1 : WLExpr.t) + (lle : (WLExpr.t option * WLExpr.t) list) : string list * Asrt.t = + let compile_pointsto = compile_pointsto ~start:false in + let exs1, la1, (loc, offset), expr_offset = + match ptr_opt with + | Some (l, bo) -> + let expr_offset = + match bo with + | Some o when not block -> Expr.LVar o + | None when block -> Expr.zero_i + | _ -> + failwith + "The algorithm to compile pointsto seems to be wrong, cannot \ + create an offset variable for a block assertion" + in + ([], [], (l, bo), expr_offset) + | None -> + let exs1, la1, e1 = compile_lexpr le1 in + let loc = gen_str sgvar in + let offset, expr_offset = + if not block then + let offset = gen_str sgvar in + (Some offset, Expr.LVar offset) + else (None, Expr.zero_i) + in + ( Option.fold ~some:(fun x -> [ x ]) ~none:[] offset @ (loc :: exs1), + Asrt.Types + ([ (Expr.LVar loc, Type.ObjectType) ] + @ + match expr_offset with + | Lit (Int _) -> [] + | _ -> [ (expr_offset, Type.IntType) ]) + :: Asrt.Pure + (Formula.Eq (e1, Expr.EList [ Expr.LVar loc; expr_offset ])) + :: la1, + (loc, offset), + expr_offset ) + in + let eloc, eoffs = (Expr.LVar loc, gil_add expr_offset curr) in + let bound = + if start && block then + [ + Constr.bound ~loc:eloc ~bound:(List.length lle) + ~permission:(Expr.num 1.0); + ] + else [] + in + match lle with + | [] -> + failwith + (Format.asprintf + "In LPointsTo assertions, a location should always point to at \ + least one value\n\ + It is not the case in : %a" WLAssert.pp asser) + | [ le ] -> + let perm, le = le in + let exs2, la2, e2 = compile_lexpr le in + let exs3, la3, e3 = + match perm with + | None -> ([], [], Expr.num 1.0) + | Some perm -> compile_lexpr perm + in + ( exs1 @ exs2 @ exs3, + concat_star + (Constr.cell ~loc:eloc ~offset:eoffs ~value:e2 ~permission:e3) + (bound @ la1 @ la2 @ la3) ) + | le :: r -> + let perm, le = le in + let exs2, la2, e2 = compile_lexpr le in + let exs3, la3, e3 = + match perm with + | None -> ([], [], Expr.num 1.0) + | Some perm -> compile_lexpr perm + in + let exs4, la4 = + compile_pointsto ~block + ~ptr_opt:(Some (loc, offset)) + le1 r ~curr:(curr + 1) + in + ( exs1 @ exs2 @ exs3 @ exs4, + concat_star + (Constr.cell ~loc:eloc ~offset:eoffs ~value:e2 ~permission:e3) + (bound @ (la4 :: (la1 @ la2 @ la3))) ) + in + WLAssert.( + match get asser with + | LEmp -> ([], Asrt.Emp) + | LStar (la1, la2) -> + let exs1, cla1 = compile_lassert la1 in + let exs2, cla2 = compile_lassert la2 in + (exs1 @ exs2, Asrt.Star (cla1, cla2)) + | LPointsTo (le1, lle) -> compile_pointsto ~block:false le1 lle + | LBlockPointsTo (le1, lle) -> compile_pointsto ~block:true le1 lle + | LPred (pr, lel) -> + let exsl, all, el = list_split_3 (List.map compile_lexpr lel) in + let exs = List.concat exsl in + let al = List.concat all in + (exs, concat_star (Asrt.Pred (pr, el)) al) + | LPure lf -> + let al, f = compile_lformula lf in + ([], concat_star (Asrt.Pure f) al)) + +let rec compile_lcmd ?(fname = "main") lcmd = + let compile_lassert = compile_lassert ~fname in + let compile_lcmd = compile_lcmd ~fname in + let compile_lexpr = compile_lexpr ~fname in + let concat_star = List.fold_left (fun a1 a2 -> Asrt.Star (a1, a2)) in + let build_assert existentials lasrts = + match lasrts with + | [] -> None + | a :: r -> + let to_assert = concat_star a r in + let cmd = LCmd.SL (SLCmd.SepAssert (to_assert, existentials)) in + (* assert (assertions) {existentials: gvars} *) + Some cmd + in + let open WLCmd in + match get lcmd with + | Fold (pname, lel) -> + let gvars, lasrts, params = list_split_3 (List.map compile_lexpr lel) in + let existentials = List.concat gvars in + let to_assert = List.concat lasrts in + ( build_assert existentials to_assert, + LCmd.SL (SLCmd.Fold (pname, params, None)) ) + | Unfold (pname, lel) -> + let gvars, lasrts, params = list_split_3 (List.map compile_lexpr lel) in + let existentials = List.concat gvars in + let to_assert = List.concat lasrts in + ( build_assert existentials to_assert, + LCmd.SL (SLCmd.Unfold (pname, params, None, false)) ) + | ApplyLem (ln, lel, bindings) -> + let gvars, lasrts, params = list_split_3 (List.map compile_lexpr lel) in + let existentials = List.concat gvars in + let to_assert = List.concat lasrts in + ( build_assert existentials to_assert, + LCmd.SL (SLCmd.ApplyLem (ln, params, bindings)) ) + | LogicIf (guard, lc1, lc2) -> + let compile_and_agregate c = + let assert_opt, clcmd = compile_lcmd c in + match assert_opt with + | None -> [ clcmd ] + | Some asser -> [ asser; clcmd ] + in + let existentials, to_assert, comp_guard = compile_lexpr guard in + let comp_lc1 = List.(concat (map compile_and_agregate lc1)) in + let comp_lc2 = List.(concat (map compile_and_agregate lc2)) in + ( build_assert existentials to_assert, + LCmd.If (comp_guard, comp_lc1, comp_lc2) ) + | Assert (la, lb) -> + let exs, comp_la = compile_lassert la in + (None, LCmd.SL (SLCmd.SepAssert (comp_la, exs @ lb))) + | Invariant _ -> failwith "Invariant is not before a loop." + +let compile_inv_and_while ~fname ~while_stmt ~invariant = + (* FIXME: Variables that are in the invariant but not existential might be wrong. *) + let loopretvar = "loopretvar__" in + let gen_str = Generators.gen_str fname in + let loop_fname = gen_str (fname ^ "_loop") in + let while_loc = WStmt.get_loc while_stmt in + let invariant_loc = WLCmd.get_loc invariant in + let inv_asrt, inv_exs, inv_variant = + match WLCmd.get invariant with + | Invariant (la, lb, lv) -> (la, lb, lv) + | _ -> failwith "That can't happen, it's not an invariant" + in + let guard, wcmds = + match WStmt.get while_stmt with + | While (e, c) -> (e, c) + | _ -> failwith "That can't happen, not a while command" + in + let lvar_exs, var_exs = List.partition Utils.Names.is_lvar_name inv_exs in + let vars, lvars = WLAssert.get_vars_and_lvars inv_asrt in + let vars, lvars = (SS.elements vars, SS.elements lvars) in + let old_lv x = "#pvar_" ^ x in + let new_lv x = "#new_pvar_" ^ x in + let pre = + let var_subst = List.map (fun x -> (x, WLExpr.LVar (old_lv x))) vars in + let subst = Hashtbl.of_seq (List.to_seq var_subst) in + let pre_without_bind = WLAssert.substitution subst inv_asrt in + List.fold_left + (fun acc (x, lx) -> + let px = WLExpr.PVar x in + let px = WLExpr.make px invariant_loc in + let lx = WLExpr.make lx invariant_loc in + let f = WLFormula.make (LEq (px, lx)) invariant_loc in + let new_a = WLAssert.make (LPure f) invariant_loc in + match WLAssert.get acc with + | LEmp -> new_a + | _ -> WLAssert.make (LStar (new_a, acc)) invariant_loc) + pre_without_bind var_subst + in + let post_subst = + let var_subst = + List.map + (fun x -> + let new_name = if List.mem x var_exs then new_lv x else old_lv x in + (x, WLExpr.LVar new_name)) + vars + in + let lvar_subst = + List.filter_map + (fun x -> + if List.mem x lvar_exs then Some (x, WLExpr.LVar (x ^ "__new")) + else None) + lvars + in + Hashtbl.of_seq (List.to_seq (var_subst @ lvar_subst)) + in + let loop_funct = + let guard_loc = WExpr.get_loc guard in + let post_guard = + WLAssert.make + (LPure + (WLFormula.not + (WLFormula.lexpr_is_true ~codeloc:guard_loc + (WLExpr.from_expr guard)))) + guard_loc + in + let post_ret = + let make_lexpr tt = WLExpr.make tt while_loc in + let make_var_lexpr x = make_lexpr (PVar x) in + let make_pvar_lexpr x = + let new_name = if List.mem x var_exs then new_lv x else old_lv x in + make_lexpr (LVar new_name) + in + WLAssert.make + (LPure + (WLFormula.make + (LEq + ( make_var_lexpr "ret", + make_lexpr (LEList (List.map make_pvar_lexpr vars)) )) + while_loc)) + while_loc + in + let post_add = + WLAssert.make (LStar (post_ret, post_guard)) (WLAssert.get_loc inv_asrt) + in + let post_without_subst = + WLAssert.make (LStar (inv_asrt, post_add)) (WLAssert.get_loc inv_asrt) + in + let post = WLAssert.substitution post_subst post_without_subst in + let spec = + WSpec. + { + pre; + post; + (* FIGURE OUT VARIANT *) + variant = inv_variant; + spid = Generators.gen_id (); + fname = loop_fname; + fparams = vars; + sploc = while_loc; + existentials = None; + } + in + let pvars = List.map (fun x -> WExpr.make (Var x) while_loc) vars in + let rec_call = + WStmt.make (FunCall (loopretvar, loop_fname, pvars, None)) while_loc + in + let allvars = WExpr.make (WExpr.List pvars) while_loc in + let ret_not_rec = WStmt.make (VarAssign (loopretvar, allvars)) while_loc in + let body = + [ + WStmt.make (If (guard, wcmds @ [ rec_call ], [ ret_not_rec ])) while_loc; + ] + in + WFun. + { + name = loop_fname; + params = vars; + body; + spec = Some spec; + return_expr = WExpr.make (Var loopretvar) while_loc; + floc = while_loc; + fid = Generators.gen_id (); + is_loop_body = true; + } + in + let retv = gen_str gvar in + let call_cmd = + Cmd.call + ( retv, + Lit (String loop_fname), + List.map (fun x -> Expr.PVar x) vars, + None, + None ) + in + let reassign_vars = + List.mapi + (fun i vn -> + Cmd.Assignment + (vn, BinOp (PVar retv, BinOp.LstNth, Lit (Int (Z.of_int i))))) + vars + in + let annot_while = + WAnnot.make ~origin_id:(WStmt.get_id while_stmt) + ~origin_loc:(CodeLoc.to_location while_loc) + ~stmt_kind:(Multi NotEnd) () + in + let rec map_reassign_vars acc = function + | cmd :: rest -> + let annot_while = + match rest with + | [] -> { annot_while with stmt_kind = Multi EndNormal } + | _ -> annot_while + in + map_reassign_vars ((annot_while, None, cmd) :: acc) rest + | [] -> List.rev acc + in + let annot_call_while = { annot_while with nest_kind = Proc loop_fname } in + let lab_cmds = + (annot_call_while, None, call_cmd) :: map_reassign_vars [] reassign_vars + in + (lab_cmds, loop_funct) + +let rec compile_stmt_list ?(fname = "main") ?(is_loop_prefix = false) stmtl = + (* create generator that works in the context of this function *) + let compile_expr = compile_expr ~fname in + let compile_lcmd = compile_lcmd ~fname in + let compile_list = compile_stmt_list ~fname in + let gen_str = Generators.gen_str fname in + let gil_expr_of_str s = Expr.Lit (Literal.String s) in + let get_or_create_lab cmdl pre = + match cmdl with + | (_, Some lab, _) :: _r -> + (cmdl, lab) (* there is already a label on the first command *) + | (a, None, c) :: r -> + let lab = gen_str pre in + ((a, Some lab, c) :: r, lab) + (* There is no label on the first command *) + | _ -> failwith "Cannot call get_or_create_lab with en empty list" + in + let nth = Expr.list_nth in + let dispose = WislLActions.str_ac WislLActions.Dispose in + let alloc = WislLActions.str_ac WislLActions.Alloc in + let load = WislLActions.str_ac WislLActions.Load in + let store = WislLActions.str_ac WislLActions.Store in + let create_func_call x fn el to_bind = + let expr_fn = gil_expr_of_str fn in + let cmdles, params = List.split (List.map compile_expr el) in + let bindings = + match to_bind with + | Some (spec_name, lvars) -> + let lvar_names = List.map fst lvars in + let compiled_lexprs = + List.map (fun (_, expr) -> compile_lexpr expr) lvars + in + let lvar_vals = + List.map + (fun tuple -> + match tuple with + | [], [], vals -> vals + | _ -> + failwith + "Something went wrong when compiling lexpr for a \ + function call. The exprs passed might not have been \ + lvars.") + compiled_lexprs + in + let lvars = List.combine lvar_names lvar_vals in + Some (spec_name, lvars) + | None -> None + in + (x, expr_fn, params, bindings, cmdles) + in + let open WStmt in + match stmtl with + | [] -> ([], []) + | { snode = Logic invariant; _ } :: while_stmt :: rest + when WLCmd.is_inv invariant && WStmt.is_while while_stmt + && !Gillian.Utils.Config.current_exec_mode = Verification -> + let cmds, fct = compile_inv_and_while ~fname ~while_stmt ~invariant in + let comp_rest, new_functions = compile_list rest in + (cmds @ comp_rest, fct :: new_functions) + | { snode = While _; _ } :: _ + when !Gillian.Utils.Config.current_exec_mode = Verification -> + failwith "While loop without invariant in Verification mode!" + | { snode = While (e, sl); sid = sid_while; sloc } :: rest -> + let looplab = gen_str loop_lab in + let cmdle, guard = compile_expr e in + let comp_body, new_functions = compile_list sl in + let comp_body, bodlab = get_or_create_lab comp_body lbody_lab in + let endlab = gen_str end_lab in + let annot_while = + WAnnot.make ~origin_id:sid_while ~origin_loc:(CodeLoc.to_location sloc) + () + in + let loopcmd = Cmd.GuardedGoto (guard, bodlab, endlab) in + let headlabopt = Some looplab in + let loopcmd_lab = (annot_while, headlabopt, loopcmd) in + let backcmd = Cmd.Goto looplab in + let backcmd_lab = (annot_while, None, backcmd) in + let endcmd = Cmd.Skip in + let endcmd_lab = (annot_while, Some endlab, endcmd) in + let comp_rest, new_functions_2 = compile_list rest in + ( cmdle @ [ loopcmd_lab ] @ comp_body + @ [ backcmd_lab; endcmd_lab ] + @ comp_rest, + new_functions @ new_functions_2 ) + (* Skip *) + | { snode = Skip; sid; sloc } :: rest -> + let cmd = Cmd.Skip in + let annot = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () + in + let comp_rest, new_functions = compile_list rest in + ((annot, None, cmd) :: comp_rest, new_functions) + (* Variable assignment *) + | { snode = VarAssign (v, e); sid; sloc } :: rest -> + let cmdle, comp_e = compile_expr e in + let cmd = Cmd.Assignment (v, comp_e) in + let annot = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () + in + let comp_rest, new_functions = compile_list rest in + (cmdle @ [ (annot, None, cmd) ] @ comp_rest, new_functions) + (* Object Deletion *) + | { snode = Dispose e; sid; sloc } :: rest -> + let cmdle, comp_e = compile_expr e in + let annot, annot_final = + let mk = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) + in + (mk ~stmt_kind:(Multi NotEnd) (), mk ~stmt_kind:(Multi EndNormal) ()) + in + let faillab, ctnlab = (gen_str fail_lab, gen_str ctn_lab) in + let testcmd = + Cmd.GuardedGoto + ( Expr.BinOp (nth comp_e 1, BinOp.Equal, Expr.Lit (Literal.Int Z.zero)), + ctnlab, + faillab ) + in + let g_var = gen_str gvar in + let failcmd = Cmd.Fail ("InvalidBlockPointer", [ comp_e ]) in + let cmd = Cmd.LAction (g_var, dispose, [ nth comp_e 0 ]) in + let comp_rest, new_functions = compile_list rest in + ( cmdle + @ [ + (annot, None, testcmd); + (annot_final, Some faillab, failcmd); + (annot_final, Some ctnlab, cmd); + ] + @ comp_rest, + new_functions ) + (* Delete e => + ce := Ce(e); // (bunch of commands and then assign the result to e) + v_get := [getcell](ce[0], ce[1]); + u := [remcell](v_get[0], v_get[1]); + *) + (* Property Lookup *) + | { snode = Lookup (x, e); sid; sloc } :: rest -> + let cmdle, comp_e = compile_expr e in + let load_annot, loadval_annot = + let mk = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) + in + (mk ~stmt_kind:(Multi NotEnd) (), mk ~stmt_kind:(Multi EndNormal) ()) + in + let v_load = gen_str gvar in + let loadcmd = + Cmd.LAction (v_load, load, [ nth comp_e 0; nth comp_e 1 ]) + in + let loadvalcmd = Cmd.Assignment (x, nth (Expr.PVar v_load) 0) in + let comp_rest, new_functions = compile_list rest in + ( cmdle + @ [ (load_annot, None, loadcmd); (loadval_annot, None, loadvalcmd) ] + @ comp_rest, + new_functions ) + (* + x := [e] => + ce := Ce(e); // (bunch of commands and then assign the result to ce) + v_load := [load](ce[0], ce[1]); + x := v_load[0]; + *) + (* Property Update *) + | { snode = Update (e1, e2); sid; sloc } :: rest -> + let store_annot = + let mk = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) + in + mk ~stmt_kind:(Multi EndNormal) () + in + let cmdle1, comp_e1 = compile_expr e1 in + let cmdle2, comp_e2 = compile_expr e2 in + let v_store = gen_str gvar in + let storecmd = + Cmd.LAction (v_store, store, [ nth comp_e1 0; nth comp_e1 1; comp_e2 ]) + in + let comp_rest, new_functions = compile_list rest in + ( cmdle1 @ cmdle2 @ ((store_annot, None, storecmd) :: comp_rest), + new_functions ) + (* [e1] := e2 => + ce1 := Ce(e1); + ce2 := Ce(e2); + l1 := ce1[0]; + o1 := ce1[1]; + u := [store](l1, o1, ce2); + *) + (* Object Creation *) + | { snode = New (x, k); sid; sloc } :: rest -> + let annot = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () + in + let newcmd = + Cmd.LAction (x, alloc, [ Expr.Lit (Literal.Int (Z.of_int k)) ]) + in + let comp_rest, new_functions = compile_list rest in + ((annot, None, newcmd) :: comp_rest, new_functions) + (* x := new(k) => + x := [alloc](k); // this is already a pointer + *) + (* Parallel composition *) + | { snode = Par funcs; sid; sloc } :: rest -> + let lambda f = + match f with + | { snode = FunCall (x, fn, el, to_bind); _ } -> + let var_name, fct_name, args, bindings, cmdles = + create_func_call x fn el to_bind + in + (Cmd.{ var_name; fct_name; args; err_lab = None; bindings }, cmdles) + | _ -> + failwith + "Parallel composition called with a node different from FunCall!" + in + let zipped = List.map lambda funcs in + let fcs = List.map (fun (f, _) -> f) zipped in + let cmdles = List.concat @@ List.map (fun (_, s) -> s) zipped in + let cmd = Cmd.Par fcs in + let annot = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () + in + let comp_rest, new_functions = compile_list rest in + (List.concat cmdles @ [ (annot, None, cmd) ] @ comp_rest, new_functions) + (* Function call *) + | { snode = FunCall (x, fn, el, to_bind); sid; sloc } :: rest -> + let x, expr_fn, params, bindings, cmdles = + create_func_call x fn el to_bind + in + let cmd = Cmd.call (x, expr_fn, params, None, bindings) in + let annot = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () + in + let comp_rest, new_functions = compile_list rest in + (List.concat cmdles @ [ (annot, None, cmd) ] @ comp_rest, new_functions) + (* If-Else bloc *) + | { snode = If (e, sl1, sl2); sid; sloc } :: rest -> + let annot = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () + in + let annot_hidden = { annot with is_hidden = true } in + let annot_prefix = + let stmt_kind = + WAnnot.(if is_loop_prefix then LoopPrefix else Single) + in + { annot with stmt_kind } + in + let cmdle, guard = compile_expr e in + let comp_sl1, new_functions1 = compile_list sl1 in + let comp_sl2, new_functions2 = compile_list sl2 in + let endlab = gen_str endif_lab in + let comp_sl1, thenlab = get_or_create_lab comp_sl1 then_lab in + let comp_sl2, elselab = get_or_create_lab comp_sl2 else_lab in + let ifelsecmd = Cmd.GuardedGoto (guard, thenlab, elselab) in + let ifelsecmd_lab = (annot_prefix, None, ifelsecmd) in + let gotoendcmd = Cmd.Goto endlab in + let gotoendcmd_lab = (annot_hidden, None, gotoendcmd) in + let endcmd = Cmd.Skip in + let endcmd_lab = (annot_hidden, Some endlab, endcmd) in + let comp_rest, new_functions3 = compile_list rest in + ( cmdle + @ (ifelsecmd_lab :: comp_sl1) + @ (gotoendcmd_lab :: comp_sl2) + @ [ endcmd_lab ] @ comp_rest, + new_functions1 @ new_functions2 @ new_functions3 ) + (* Logic commands *) + | { snode = Logic lcmd; sid; sloc } :: rest -> + let annot = + WAnnot.make ~origin_id:sid ~origin_loc:(CodeLoc.to_location sloc) () + in + let to_assert_opt, clcmd = compile_lcmd lcmd in + let lcmds = + match to_assert_opt with + | None -> [ clcmd ] + | Some to_assert -> [ to_assert; clcmd ] + in + let cmds_with_annot = + List.map (fun lcmdp -> (annot, None, Cmd.Logic lcmdp)) lcmds + in + let comp_rest, new_functions = compile_list rest in + (cmds_with_annot @ comp_rest, new_functions) + +let compile_spec + ?(fname = "main") + WSpec.{ pre; post; variant; fparams; existentials; _ } = + let _, comp_pre = compile_lassert ~fname pre in + let _, comp_post = compile_lassert ~fname post in + let comp_variant = + Option.map + (fun variant -> + (* FIXME: what happens with the global assertions? *) + let _, _, comp_variant = compile_lexpr variant in + comp_variant) + variant + in + let label_opt = + match existentials with + | None -> None + | Some (n, ss) -> Some (n, ss) + in + let single_spec = + match label_opt with + | None -> Spec.s_init comp_pre [ comp_post ] comp_variant Flag.Normal true + | Some ss_label -> + Spec.s_init ~ss_label comp_pre [ comp_post ] comp_variant Flag.Normal + true + in + Spec.init fname fparams [ single_spec ] false false true + +let compile_pred filepath pred = + let WPred.{ pred_definitions; pred_params; pred_name; pred_ins; _ } = pred in + let types = WType.infer_types_pred pred_params pred_definitions in + let getWISLTypes str = (str, WType.of_variable str types) in + let paramsWISLType = List.map (fun (x, _) -> getWISLTypes x) pred_params in + let getGILTypes (str, t) = + (str, Option.fold ~some:compile_type ~none:None t) + in + let pred_params = List.map getGILTypes paramsWISLType in + let build_def pred_def = + let _, casrt = compile_lassert pred_def in + (None, casrt, []) + in + Pred. + { + pred_name; + pred_source_path = Some filepath; + pred_internal = false; + pred_num_params = List.length pred_params; + pred_params; + pred_ins; + pred_definitions = List.map build_def pred_definitions; + pred_normalised = false; + (* FIXME: ADD SUPPORT FOR ABSTRACT, PURE, NOUNFOLD *) + pred_guard = None; + pred_facts = []; + pred_abstract = false; + pred_pure = false; + pred_nounfold = pred.pred_nounfold; + } + +let rec compile_function + filepath + WFun.{ name; params; body; spec; return_expr; is_loop_body; _ } = + let lbodylist, new_functions = + compile_stmt_list ~fname:name ~is_loop_prefix:is_loop_body body + in + let other_procs = + List.concat (List.map (compile_function filepath) new_functions) + in + let cmdle, comp_ret_expr = compile_expr ~fname:name return_expr in + let ret_annot, final_ret_annot = + let mk = + WAnnot.make + ~origin_loc:(CodeLoc.to_location (WExpr.get_loc return_expr)) + ~origin_id:(WExpr.get_id return_expr) + in + (mk ~stmt_kind:(Multi NotEnd) (), mk ~stmt_kind:(Multi EndNormal) ()) + in + let retassigncmds = + cmdle + @ [ + ( ret_annot, + None, + Cmd.Assignment (Gillian.Utils.Names.return_variable, comp_ret_expr) ); + ] + in + let retcmd = (final_ret_annot, None, Cmd.ReturnNormal) in + let lbody_withret = lbodylist @ retassigncmds @ [ retcmd ] in + let gil_body = Array.of_list lbody_withret in + let gil_spec = Option.map (compile_spec ~fname:name) spec in + Proc. + { + proc_name = name; + proc_source_path = Some filepath; + proc_internal = false; + proc_body = gil_body; + proc_spec = gil_spec; + proc_params = params; + } + :: other_procs + +let preprocess_lemma + WLemma. + { + lemma_name; + lemma_params; + lemma_proof; + lemma_variant; + lemma_hypothesis; + lemma_conclusion; + lemma_id; + lemma_loc; + } = + let lvar_params = List.map (fun x -> "#" ^ x) lemma_params in + let param_subst = Hashtbl.create 1 in + let lvar_params_eqs : WLAssert.t list = + List.map2 + (fun x lvarx -> + let ex = WLExpr.make (PVar x) lemma_loc in + let elx = WLExpr.make (LVar lvarx) lemma_loc in + Hashtbl.replace param_subst x (WLExpr.LVar lvarx); + let formula = WLFormula.make (LEq (ex, elx)) lemma_loc in + WLAssert.make (LPure formula) lemma_loc) + lemma_params lvar_params + in + let lvar_params_eq : WLAssert.t = + let lvar_params_eq = + List.fold_left + (fun ac next -> WLAssert.LStar (WLAssert.make ac lemma_loc, next)) + WLAssert.LEmp lvar_params_eqs + in + WLAssert.make lvar_params_eq lemma_loc + in + let new_lemma_hypothesis = + WLAssert.substitution param_subst lemma_hypothesis + in + let new_lemma_hypothesis = + WLAssert.make + (WLAssert.LStar (lvar_params_eq, new_lemma_hypothesis)) + lemma_loc + in + let new_lemma_conclusion = + WLAssert.substitution param_subst lemma_conclusion + in + let new_lemma_proof = + Option.map (List.map (WLCmd.substitution param_subst)) lemma_proof + in + WLemma. + { + lemma_name; + lemma_params; + lemma_proof = new_lemma_proof; + lemma_variant; + lemma_hypothesis = new_lemma_hypothesis; + lemma_conclusion = new_lemma_conclusion; + lemma_id; + lemma_loc; + } + +let compile_lemma + filepath + WLemma. + { + lemma_name; + lemma_params; + lemma_proof; + lemma_variant; + lemma_hypothesis; + lemma_conclusion; + _; + } = + let compile_lcmd = compile_lcmd ~fname:lemma_name in + let compile_lexpr = compile_lexpr ~fname:lemma_name in + let compile_lassert = compile_lassert ~fname:lemma_name in + let compile_and_agregate_lcmd lcmd = + let a_opt, clcmd = compile_lcmd lcmd in + match a_opt with + | None -> [ clcmd ] + | Some a -> [ a; clcmd ] + in + let lemma_proof = + Option.map + (fun l -> List.(concat (map compile_and_agregate_lcmd l))) + lemma_proof + in + (* FIXME: compilation can get wrong here if we compile stuff with pointer arith in the variant *) + (* FIXME: not sure where the global assertions should go *) + let lemma_variant = + Option.map + (fun x -> + let _, _, comp_lexpr = compile_lexpr x in + comp_lexpr) + lemma_variant + in + let _, lemma_hyp = compile_lassert lemma_hypothesis in + let _, post = compile_lassert lemma_conclusion in + let lemma_existentials = [] in + (* TODO: What about existentials for lemma in WISL ? *) + Lemma. + { + lemma_name; + lemma_source_path = Some filepath; + lemma_internal = false; + lemma_params; + lemma_proof; + lemma_variant; + lemma_specs = + [ + { + lemma_hyp; + lemma_concs = [ post ]; + lemma_spec_variant = lemma_variant; + lemma_spec_hides = None; + }; + ]; + lemma_existentials; + } + +let compile ~filepath WProg.{ context; predicates; lemmas } = + (* stuff useful to build hashtables *) + let make_hashtbl get_name deflist = + let hashtbl = Hashtbl.create (List.length deflist) in + let () = + List.iter (fun def -> Hashtbl.add hashtbl (get_name def) def) deflist + in + hashtbl + in + let get_proc_name proc = proc.Proc.proc_name in + let get_pred_name pred = pred.Pred.pred_name in + let get_lemma_name lemma = lemma.Lemma.lemma_name in + (* compile everything *) + let comp_context = List.map (compile_function filepath) context in + let comp_preds = List.map (compile_pred filepath) predicates in + let comp_lemmas = + List.map + (fun lemma -> compile_lemma filepath (preprocess_lemma lemma)) + lemmas + in + (* build the hashtables *) + let gil_procs = make_hashtbl get_proc_name (List.concat comp_context) in + let gil_preds = make_hashtbl get_pred_name comp_preds in + let gil_lemmas = make_hashtbl get_lemma_name comp_lemmas in + let proc_names = Hashtbl.fold (fun s _ l -> s :: l) gil_procs [] in + Prog. + { + imports = + List.map (fun imp -> (imp, false)) WislConstants.internal_imports; + lemmas = gil_lemmas; + preds = gil_preds; + procs = gil_procs; + proc_names; + only_specs = Hashtbl.create 1; + macros = Hashtbl.create 1; + bi_specs = Hashtbl.create 1; + predecessors = Hashtbl.create 1; + } diff --git a/wislfp/lib/ParserAndCompiler/wisl2Gil.mli b/wislfp/lib/ParserAndCompiler/wisl2Gil.mli new file mode 100644 index 000000000..903225ab8 --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/wisl2Gil.mli @@ -0,0 +1,3 @@ +open Gillian.Gil_syntax + +val compile : filepath:string -> WProg.t -> (WAnnot.t, string) Prog.t diff --git a/wislfp/lib/ParserAndCompiler/wislConstants.ml b/wislfp/lib/ParserAndCompiler/wislConstants.ml new file mode 100644 index 000000000..4d7fdffc1 --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/wislConstants.ml @@ -0,0 +1,39 @@ +let internal_imports = [ "wisl_pointer_arith.gil"; "wisl_core.gil" ] +let internal_prefix = "i__" + +module Prefix = struct + let gvar = "gvar" + let sgvar = "#wisl__" + let loopinv_lab = "loopinv" + let loop_lab = "loop" + let ctn_lab = "continue" + let fail_lab = "fail" + let lbody_lab = "lbody" + let end_lab = "end" + let endif_lab = "endif" + let then_lab = "then" + let else_lab = "else" +end + +module InternalProcs = struct + let proc_prefix = "" + let i x = internal_prefix ^ proc_prefix ^ x + let internal_add = i "add" + let internal_minus = i "minus" + let internal_gt = i "gt" + let internal_lt = i "lt" + let internal_leq = i "leq" + let internal_geq = i "geq" +end + +module InternalPreds = struct + let pred_prefix = "pred_" + let i x = internal_prefix ^ pred_prefix ^ x + let internal_pred_cell = i "cell" + let internal_pred_add = i "add" + let internal_pred_minus = i "minus" + let internal_pred_gt = i "gt" + let internal_pred_lt = i "lt" + let internal_pred_geq = i "geq" + let internal_pred_leq = i "leq" +end diff --git a/wislfp/lib/ParserAndCompiler/wislConstants.mli b/wislfp/lib/ParserAndCompiler/wislConstants.mli new file mode 100644 index 000000000..07b31ebf4 --- /dev/null +++ b/wislfp/lib/ParserAndCompiler/wislConstants.mli @@ -0,0 +1,90 @@ +val internal_imports : string list + +module Prefix : sig + (** This module contains the prefix for different kind of strings that are generated during compilation *) + + (** Prefix for generated variables *) + val gvar : string + + (** Prefix for generated symbolic variables *) + val sgvar : string + + (** Prefix for loop invariant labels *) + val loopinv_lab : string + + (** Prefix for loop begining labels *) + val loop_lab : string + + (** Prefix for continue labels *) + val ctn_lab : string + + (** Prefix for fail labels *) + val fail_lab : string + + (** Prefix for loop body labels *) + val lbody_lab : string + + (** Prefix for end of loop body labels *) + val end_lab : string + + (** Prefix for end of if/else bloc labels *) + val endif_lab : string + + (** Prefix for then labels *) + val then_lab : string + + (** Prefix for else labels *) + val else_lab : string +end + +module InternalProcs : sig + (** This module contains the name of the internal procedures of WISL implemented in GIL + They take into account pointer arithmetics. + For example, the function that has the name [internal_add] adds either to numbers, or a pointer and a number. + *) + + (** add(a,b) computes a + b (taking pointer arithmetics into account) *) + val internal_add : string + + (** minus(a,b) computes a - b *) + val internal_minus : string + + (** gt(a,b) computes a > b *) + val internal_gt : string + + (** lt(a,b) computes a < b *) + val internal_lt : string + + (** leq(a, b) computes a <= b *) + val internal_leq : string + + (** geq(a, b) computes a >= b *) + val internal_geq : string +end + +module InternalPreds : sig + (** This module contains the name of internal predicates for WISL implemented in GIL. + They take pointer arithmetics into account. + For example, [internal_pred_add(x, y, z)] is true if [internal_add(x, y)] would return [z]. *) + + (** cell predicate. [cell(ptr, value)] in gil means [ptr -> value] in wisl *) + val internal_pred_cell : string + + (** [internal_pred_add(x, y, z)] is true if executing [internal_add(x, y)] would return [z]. *) + val internal_pred_add : string + + (** [internal_pred_minus(x, y, z)] is true if executing [internal_minus(x, y)] would return [z]. *) + val internal_pred_minus : string + + (** [internal_pred_lt(x, y, z)] is true if executing [internal_lt(x, y)] would return [z]. *) + val internal_pred_lt : string + + (** [internal_pred_gt(x, y, z)] is true if executing [internal_gt(x, y)] would return [z]. *) + val internal_pred_gt : string + + (** [internal_pred_leq(x, y, z)] is true if executing [internal_leq(x, y)] would return [z]. *) + val internal_pred_leq : string + + (** [internal_pred_geq(x, y, z)] is true if executing [internal_geq(x, y)] would return [z]. *) + val internal_pred_geq : string +end diff --git a/wislfp/lib/debugging/dune b/wislfp/lib/debugging/dune new file mode 100644 index 000000000..38387e1b1 --- /dev/null +++ b/wislfp/lib/debugging/dune @@ -0,0 +1,6 @@ +(library + (name pwDebugging) + (libraries gillian str pwParserAndCompiler pwSemantics pwSyntax pwUtils) + (preprocess + (pps ppx_deriving.std ppx_deriving_yojson)) + (flags :standard -open PwUtils -open Gillian -open Gillian.Utils.Prelude)) diff --git a/wislfp/lib/debugging/wislLifter.ml b/wislfp/lib/debugging/wislLifter.ml new file mode 100644 index 000000000..fb405760b --- /dev/null +++ b/wislfp/lib/debugging/wislLifter.ml @@ -0,0 +1,816 @@ +open PwSemantics +open PwSyntax +open Gil_syntax +module L = Logging +module DL = Debugger_log +module Exec_map = Debugger.Utils.Exec_map +module Unify_map = Debugger.Utils.Unify_map +open Syntaxes.Option +module Ext_list = Utils.Ext_list +module Annot = PwParserAndCompiler.Annot +open Annot +open WBranchCase +open Debugger.Lifter + +type rid = L.Report_id.t [@@deriving yojson, show] + +module Make + (Gil : Gillian.Debugger.Lifter.Gil_fallback_lifter.Gil_lifter_with_state) + (Verification : Engine.Verifier.S with type annot = Annot.t) = +struct + open Exec_map + + type memory_error = WislSMemory.err_t + type tl_ast = PwParserAndCompiler.tl_ast + type memory = WislSMemory.t + type annot = Annot.t + + module CmdReport = Verification.SAInterpreter.Logging.ConfigReport + module Gil_lifter = Gil.Lifter + + type cmd_report = CmdReport.t [@@deriving yojson] + type branch_case = WBranchCase.t [@@deriving yojson] + type branch_data = rid * BranchCase.t option [@@deriving yojson] + type exec_data = cmd_report executed_cmd_data [@@deriving yojson] + + let annot_to_wisl_stmt annot wisl_ast = + let origin_id = annot.origin_id in + let wprog = WProg.get_by_id wisl_ast origin_id in + match wprog with + | `WStmt wstmt -> + DL.log (fun m -> m "WISL STMT: %a" WStmt.pp wstmt); + Some wstmt.snode + | _ -> None + + let get_origin_node_str wisl_ast origin_id = + let node = WProg.get_by_id wisl_ast origin_id in + match node with + | `Return we -> Some (Fmt.str "return %a" WExpr.pp we) + | `WExpr we -> Some (Fmt.str "Evaluating: %a" WExpr.pp we) + | `WLCmd lcmd -> Some (Fmt.str "%a" WLCmd.pp lcmd) + | `WStmt stmt -> Some (Fmt.str "%a" WStmt.pp_head stmt) + | `WLExpr le -> Some (Fmt.str "LEXpr: %a" WLExpr.pp le) + | `WFun f -> Some (Fmt.str "WFun: %s" f.name) + | `None -> None + | _ -> failwith "get_origin_node_str: Unknown Kind of Node" + + let get_fun_call_name exec_data = + let cmd = CmdReport.(exec_data.cmd_report.cmd) in + match cmd with + | Cmd.Call { fct_name; _ } -> ( + match fct_name with + | Expr.Lit (Literal.String name) -> Some name + | _ -> + failwith "get_fun_call_name: function name wasn't a literal expr!") + | _ -> None + + type map = (branch_case, cmd_data, branch_data) Exec_map.t + + and cmd_data = { + ids : rid list; + display : string; + unifys : unification list; + errors : string list; + submap : map submap; + gil_branch_path : BranchCase.path; + branch_path : branch_case list; + parent : parent; [@to_yojson fun _ -> `Null] + } + + and parent = (map * (branch_data * branch_case) option) option + [@@deriving yojson] + + module PartialCmds = struct + type partial_data = { + display : string; + ids : rid Ext_list.t; + errors : string Ext_list.t; + mutable submap : map submap; + mutable inner_path : branch_data list; + unifys : unification Ext_list.t; + unexplored_paths : branch_data list Stack.t; + out_paths : (branch_case * branch_data list) Ext_list.t; + mutable unknown_outs_count : int; + } + [@@deriving to_yojson] + + let make_partial_data display = + { + display; + ids = Ext_list.make (); + errors = Ext_list.make (); + unifys = Ext_list.make (); + submap = NoSubmap; + inner_path = []; + unexplored_paths = Stack.create (); + out_paths = Ext_list.make (); + unknown_outs_count = 0; + } + + type t = (int, partial_data) Hashtbl.t [@@deriving to_yojson] + + let update_partial_data end_kind exec_data d = + let { id; unifys; errors; cmd_report; _ } = exec_data in + let annot = CmdReport.(cmd_report.annot) in + d.ids |> Ext_list.append id; + unifys |> List.iter (fun unify -> d.unifys |> Ext_list.append unify); + errors |> List.iter (fun error -> d.errors |> Ext_list.append error); + (match exec_data.kind with + | Branch cases -> + cases + |> List.iter (fun (case, _) -> + let path = (id, Some case) :: d.inner_path in + match end_kind with + | NotEnd -> d.unexplored_paths |> Stack.push path + | EndNormal -> + let count = d.unknown_outs_count in + let case = Gil count in + d.unknown_outs_count <- count + 1; + d.out_paths |> Ext_list.append (case, path) + | EndWithBranch _ -> + failwith "EndWithBranch on branching cmd not supported!") + | Normal -> ( + let path = (id, None) :: d.inner_path in + match end_kind with + | NotEnd -> () + | EndNormal -> + let count = d.unknown_outs_count in + let case = Gil count in + d.unknown_outs_count <- count + 1; + d.out_paths |> Ext_list.append (case, path) + | EndWithBranch case -> d.out_paths |> Ext_list.append (case, path)) + | Final -> ()); + match (d.submap, annot.nest_kind) with + | _, NoNest -> () + | NoSubmap, Proc p -> d.submap <- Proc p + | _, _ -> + DL.failwith + (fun () -> + [ + ("annot", Annot.to_yojson annot); + ("exec_data", exec_data_to_yojson exec_data); + ("partial_data", partial_data_to_yojson d); + ]) + "WislLifter.update_partial_data: multiple submaps in WISL \ + statement!" + + type partial_cmd_result = + | Finished of { + ids : rid list; + display : string; + unifys : unification list; + errors : string list; + cmd_kind : (branch_case, branch_data) cmd_kind; + submap : map submap; + } + | StepAgain of (rid option * BranchCase.t option) + + let make_finished_partial + is_final + { ids; display; unifys; errors; out_paths; submap; _ } = + let ids = ids |> Ext_list.to_list in + let unifys = unifys |> Ext_list.to_list in + let errors = errors |> Ext_list.to_list in + let cmd_kind = + match out_paths |> Ext_list.to_list with + | [] | [ (_, [ (_, None) ]) ] -> if is_final then Final else Normal + | paths -> + let cases = + paths + |> List.map (fun (case, path) -> + let branch_data = List.hd path in + (case, branch_data)) + in + Branch cases + in + Finished { ids; display; unifys; errors; cmd_kind; submap } + + let update annot (d : partial_data) (exec_data : exec_data) : + partial_cmd_result = + let failwith s = + DL.failwith + (fun () -> + [ + ("annot", Annot.to_yojson annot); + ("exec_data", exec_data_to_yojson exec_data); + ("partial_data", partial_data_to_yojson d); + ]) + ("WislLifter.PartialCmds.update: " ^ s) + in + let end_kind = + match annot.stmt_kind with + | Multi b -> b + | _ -> failwith "tried to update partial with non-Multi cmd!" + in + d |> update_partial_data end_kind exec_data; + let is_final, result = + match (exec_data.kind, end_kind) with + | Final, _ -> (true, None) + | _, (EndNormal | EndWithBranch _) | Branch _, _ -> (false, None) + | Normal, _ -> (false, Some (StepAgain (None, None))) + in + match result with + | Some r -> r + | None -> ( + match d.unexplored_paths |> Stack.pop_opt with + | Some path -> + let id, gil_case = List.hd path in + d.inner_path <- path; + StepAgain (Some id, gil_case) + | None -> make_finished_partial is_final d) + + let create annot tl_ast = + match annot.stmt_kind with + | Multi NotEnd -> + let* origin_id = annot.origin_id in + let+ display = get_origin_node_str tl_ast (Some origin_id) in + make_partial_data display + | _ -> None + + let handle exec_data tl_ast partial_cmds = + let annot = + let cmd_report = exec_data.cmd_report in + CmdReport.(cmd_report.annot) + in + let* origin_id = annot.origin_id in + let+ partial_data = + match Hashtbl.find_opt partial_cmds origin_id with + | None -> + let+ pd = create annot tl_ast in + Hashtbl.add partial_cmds origin_id pd; + pd + | pd -> pd + in + let result = update annot partial_data exec_data in + (match result with + | Finished _ -> Hashtbl.remove partial_cmds origin_id + | _ -> ()); + result + end + + type t = { + proc_name : string; + gil_state : Gil_lifter.t; [@to_yojson Gil_lifter.dump] + tl_ast : tl_ast; [@to_yojson fun _ -> `Null] + partial_cmds : PartialCmds.t; + mutable map : map; + id_map : (rid, map) Hashtbl.t; [@to_yojson fun _ -> `Null] + mutable before_partial : (rid * BranchCase.t option) option; + mutable is_loop_func : bool; + } + [@@deriving to_yojson] + + let path_of_map = function + | Nothing -> [] + | Cmd { data; _ } | BranchCmd { data; _ } | FinalCmd { data } -> + data.branch_path + + let gil_path_of_map = function + | Nothing -> [] + | Cmd { data; _ } | BranchCmd { data; _ } | FinalCmd { data } -> + data.gil_branch_path + + let id_of_map_opt ?(last = false) = function + | Nothing -> None + | Cmd { data; _ } | BranchCmd { data; _ } | FinalCmd { data } -> + if last then Some (List.hd (List.rev data.ids)) + else Some (List.hd data.ids) + + let id_of_map ?(last = false) map = + match id_of_map_opt ~last map with + | None -> failwith "id_of_map: Nothing" + | Some id -> id + + let new_cmd + id_map + kind + ids + display + unifys + errors + gil_branch_path + ?(submap = NoSubmap) + ~(parent : parent) + () : map = + let branch_path = + match parent with + | None -> [] + | Some (parent_map, case) -> ( + let parent_path = path_of_map parent_map in + match case with + | None -> parent_path + | Some (_, case) -> case :: parent_path) + in + let data = + { + ids; + display; + unifys; + errors; + submap; + gil_branch_path; + branch_path; + parent; + } + in + let cmd = + match kind with + | Normal -> Cmd { data; next = Nothing } + | Branch cases -> ( + match cases with + | [ (Gil _, (_, None)) ] -> Cmd { data; next = Nothing } + | _ -> + let nexts = Hashtbl.create (List.length cases) in + cases + |> List.iter (fun (case, bdata) -> + Hashtbl.add nexts case (bdata, Nothing)); + BranchCmd { data; nexts }) + | Final -> FinalCmd { data } + in + ids |> List.iter (fun id -> Hashtbl.replace id_map id cmd); + cmd + + let dump = to_yojson + + let convert_kind id = function + | Normal -> Normal + | Final -> Final + | Branch cases -> ( + match cases with + | (BranchCase.GuardedGoto _, ()) :: _ -> + let cases = + cases + |> List.map (fun (case, _) -> + match case with + | BranchCase.GuardedGoto b -> (IfElse b, (id, Some case)) + | _ -> failwith "convert_kind: inconsistent branch cases!") + in + Branch cases + | (BranchCase.LCmd _, ()) :: _ -> + let cases = + cases + |> List.map (fun (case, _) -> + match case with + | BranchCase.LCmd lcmd -> (LCmd lcmd, (id, Some case)) + | _ -> failwith "convert_kind: inconsistent branch cases!") + in + Branch cases + | _ -> failwith "convert_kind: unsupported branch case!") + + let rec insert_new_cmd + (new_cmd : parent:parent -> unit -> map) + (new_id : rid) + (id : rid) + (gil_case : BranchCase.t option) + state = + let failwith s = failwith ("WislLifter.insert_new_cmd: " ^ s) in + let { id_map; gil_state; _ } = state in + match Hashtbl.find_opt id_map id with + | None -> ( + DL.log (fun m -> + m "couldn't find id %a; attempting with previous step from GIL." + pp_rid id); + match gil_state |> Gil_lifter.previous_step id with + | None -> failwith "couldn't step back any farther!" + | Some (prev_id, _) -> + insert_new_cmd new_cmd new_id prev_id gil_case state) + | Some map -> ( + match map with + | Cmd c -> + let parent = Some (map, None) in + c.next <- new_cmd ~parent () + | BranchCmd { nexts; _ } -> + let case, next, bdata = + match gil_case with + | None -> + let rec aux new_id = + let result = + nexts + |> Hashtbl.find_map (fun case (bdata, next) -> + match bdata with + | case_id, None when case_id = new_id -> + Some (case, next, bdata) + | _ -> None) + in + match result with + | Some r -> r + | None -> ( + let prev = + gil_state |> Gil_lifter.previous_step new_id + in + match prev with + | Some (new_id, _) -> + DL.log (fun m -> + m + "Inserting without gil case; attempting to \ + look back for link"); + aux new_id + | _ -> + failwith + "HORROR - tried to insert without branch case!") + in + aux new_id + | Some gil_case -> + Hashtbl.find_map + (fun case (bdata, next) -> + let gil_case' = bdata |> snd |> Option.get in + if gil_case <> gil_case' then None + else Some (case, next, bdata)) + nexts + |> Option.get + in + if next <> Nothing then + failwith "HORROR - tried to insert to non-Nothing!"; + let parent = Some (map, Some (bdata, case)) in + Hashtbl.replace nexts case (bdata, new_cmd ~parent ()) + | _ -> failwith "HORROR - tried to insert to FinalCmd or Nothing!") + + let prepare_basic_cmd ?display ?(final = false) tl_ast id_map exec_data = + let { cmd_report; _ } = exec_data in + let annot = CmdReport.(cmd_report.annot) in + let { origin_id; nest_kind; _ } = annot in + let display = + match display with + | Some d -> d + | None -> + get_origin_node_str tl_ast origin_id + |> Option.value ~default:"Unknown command!" + in + let { id; unifys; errors; branch_path = gil_branch_path; kind; _ } = + exec_data + in + let submap = + match nest_kind with + | NoNest -> NoSubmap + | Proc p -> Proc p + in + let kind = if final then Final else convert_kind id kind in + new_cmd id_map kind [ id ] display unifys errors gil_branch_path ~submap + + let handle_loop_prefix exec_data = + let annot = CmdReport.(exec_data.cmd_report.annot) in + match annot.stmt_kind with + | LoopPrefix -> + Some + (match exec_data.cmd_report.cmd with + | Cmd.GuardedGoto _ -> + ExecNext (None, Some (BranchCase.GuardedGoto true)) + | _ -> ExecNext (None, None)) + | _ -> None + + let init_or_handle prev_id branch_case exec_data state = + let Debugger.Lifter.{ id; _ } = exec_data in + DL.log (fun m -> + m + ~json: + [ + ("state", dump state); ("exec_data", exec_data_to_yojson exec_data); + ] + "HANDLING %a (prev %a)" L.Report_id.pp id (pp_option L.Report_id.pp) + prev_id); + let { tl_ast; partial_cmds; id_map; proc_name; is_loop_func; _ } = state in + match handle_loop_prefix exec_data with + | Some result -> + state.is_loop_func <- true; + result + | None -> ( + match PartialCmds.handle exec_data tl_ast partial_cmds with + | Some (StepAgain result) -> + if Option.is_none state.before_partial then + prev_id + |> Option.iter (fun prev_id -> + state.before_partial <- Some (prev_id, branch_case)); + ExecNext result + | None -> + let display, final = + if is_loop_func && get_fun_call_name exec_data = Some proc_name + then (Some "", true) + else (None, false) + in + let new_cmd = + prepare_basic_cmd ?display ~final tl_ast id_map exec_data + in + (match (state.map, prev_id) with + | Nothing, _ -> state.map <- new_cmd ~parent:None () + | _, Some prev_id -> + insert_new_cmd new_cmd id prev_id branch_case state + | _, _ -> + failwith + "HORROR - tried to insert to non-Nothing map without \ + previous id!"); + Stop + | Some (Finished { ids; display; unifys; errors; cmd_kind; submap }) -> + let gil_branch_path = + Gil_lifter.path_of_id (List.hd ids) state.gil_state + in + let new_cmd = + new_cmd id_map cmd_kind ids display unifys errors gil_branch_path + ~submap + in + let prev_id, branch_case = + match state.before_partial with + | Some (prev_id, branch_case) -> + state.before_partial <- None; + (Some prev_id, branch_case) + | None -> (prev_id, branch_case) + in + (match (state.map, prev_id) with + | Nothing, _ -> state.map <- new_cmd ~parent:None () + | _, Some prev_id -> + insert_new_cmd new_cmd id prev_id branch_case state + | _, _ -> + failwith + "HORROR - tried to insert to non-Nothing map without \ + previous id!"); + Stop) + + let init proc_name tl_ast exec_data = + let gil_state = Gil.get_state () in + let+ tl_ast = tl_ast in + let partial_cmds = Hashtbl.create 0 in + let id_map = Hashtbl.create 0 in + let before_partial = None in + let state = + { + proc_name; + gil_state; + tl_ast; + partial_cmds; + map = Nothing; + id_map; + before_partial; + is_loop_func = false; + } + in + let result = init_or_handle None None exec_data state in + (state, result) + + let init_exn proc_name tl_ast exec_data = + match init proc_name tl_ast exec_data with + | None -> failwith "init: wislLifter needs a tl_ast!" + | Some x -> x + + let handle_cmd prev_id branch_case (exec_data : exec_data) state = + init_or_handle (Some prev_id) branch_case exec_data state + + let get_gil_map _ = failwith "get_gil_map: not implemented!" + + let package_case (bd : branch_data) (case : branch_case) : + Packaged.branch_case = + let json = branch_case_to_yojson case in + let kind, display = + match case with + | IfElse b -> ("IfElse", ("If/Else", Fmt.str "%B" b)) + | LCmd x -> ("LCmd", ("Logical command", Fmt.str "%d" x)) + | Gil _ -> ( + let id, gil_case = bd in + match gil_case with + | Some gil_case -> + let kind_display, display = + Packaged.(package_gil_case gil_case).display + in + let kind = "GIL" in + let kind_display = Fmt.str "(GIL) %s" kind_display in + let display = Fmt.str "(%a) %s" pp_rid id display in + (kind, (kind_display, display)) + | None -> ("GIL", ("(GIL) Unknown", Fmt.str "(%a) Unknown" pp_rid id)) + ) + in + { kind; display; json } + + let package_data package { ids; display; unifys; errors; submap; _ } = + let submap = + match submap with + | NoSubmap -> NoSubmap + | Proc p -> Proc p + | Submap map -> Submap (package map) + in + Packaged.{ ids; display; unifys; errors; submap } + + let package = Packaged.package package_data package_case + let get_lifted_map_exn { map; _ } = package map + let get_lifted_map state = Some (get_lifted_map_exn state) + + let get_unifys_at_id id { id_map; _ } = + let map = Hashtbl.find id_map id in + match map with + | Cmd { data; _ } | BranchCmd { data; _ } | FinalCmd { data } -> data.unifys + | _ -> failwith "get_unifys_at_id: HORROR - tried to get unifys at non-cmd!" + + let get_root_id { map; _ } = + match map with + | Nothing -> None + | Cmd { data; _ } | BranchCmd { data; _ } | FinalCmd { data } -> + Some (List.hd data.ids) + + let path_of_id id { id_map; _ } = + let map = Hashtbl.find id_map id in + gil_path_of_map map + + let existing_next_steps id { gil_state; id_map; _ } = + Gil_lifter.existing_next_steps id gil_state + |> List.filter (fun (id, _) -> Hashtbl.mem id_map id) + + let next_gil_step id case state = + let failwith s = + DL.failwith + (fun () -> + [ + ("state", dump state); + ("id", rid_to_yojson id); + ("case", opt_to_yojson Packaged.branch_case_to_yojson case); + ]) + ("next_gil_step: " ^ s) + in + match (Hashtbl.find state.id_map id, case) with + | Nothing, _ -> failwith "HORROR - cmd at id is Nothing!" + | FinalCmd _, _ -> failwith "can't get next at final cmd!" + | Cmd _, Some _ -> failwith "got branch case at non-branch cmd!" + | BranchCmd _, None -> failwith "expected branch case at branch cmd!" + | Cmd { data; _ }, None -> + let id = List.hd (List.rev data.ids) in + (id, None) + | BranchCmd { nexts; _ }, Some case -> ( + let case = + Packaged.(case.json) |> branch_case_of_yojson |> Result.get_ok + in + match Hashtbl.find_opt nexts case with + | None -> failwith "branch case not found!" + | Some ((id, case), _) -> (id, case)) + + let previous_step id { id_map; _ } = + match Hashtbl.find id_map id with + | Nothing -> None + | Cmd { data; _ } | BranchCmd { data; _ } | FinalCmd { data } -> + let+ parent, case = data.parent in + let id = id_of_map parent in + let case = + case |> Option.map (fun (bdata, case) -> package_case bdata case) + in + (id, case) + + let select_next_path case id { gil_state; _ } = + Gil_lifter.select_next_path case id gil_state + + let find_unfinished_path ?at_id state = + let { map; id_map; _ } = state in + let rec aux = function + | Nothing -> + DL.failwith + (fun () -> + [ + ("state", dump state); + ("at_id", opt_to_yojson rid_to_yojson at_id); + ]) + "find_unfinished_path: started at Nothing" + | Cmd { data = { ids; _ }; next = Nothing } -> + let id = List.hd (List.rev ids) in + Some (id, None) + | Cmd { next; _ } -> aux next + | BranchCmd { nexts; _ } -> ( + match + Hashtbl.find_map + (fun _ ((id, gil_case), next) -> + if next = Nothing then Some (id, gil_case) else None) + nexts + with + | None -> Hashtbl.find_map (fun _ (_, next) -> aux next) nexts + | result -> result) + | FinalCmd _ -> None + in + let map = + match at_id with + | None -> map + | Some id -> Hashtbl.find id_map id + in + aux map + + let get_wisl_stmt gil_cmd wisl_ast = + let* annot = + match gil_cmd with + | Some (_, annot) -> Some annot + | _ -> None + in + annot_to_wisl_stmt annot wisl_ast + + let get_cell_var_from_cmd gil_cmd wisl_ast = + let open Syntaxes.Option in + match wisl_ast with + | Some ast -> ( + let* stmt = get_wisl_stmt gil_cmd ast in + match stmt with + | WStmt.Lookup (_, e) | WStmt.Update (e, _) -> Some (WExpr.str e) + | _ -> None) + | None -> ( + let open WislLActions in + match gil_cmd with + | Some (Cmd.LAction (_, name, [ _; Expr.BinOp (PVar var, _, _) ]), _) + when name = str_ac GetCell -> Some var + | _ -> None) + + let free_error_to_string msg_prefix prev_annot gil_cmd wisl_ast = + let open Syntaxes.Option in + let var = + match wisl_ast with + | Some ast -> ( + let* stmt = get_wisl_stmt gil_cmd ast in + match stmt with + (* TODO: Catch all the cases that use after free can happen to get the + variable names *) + | WStmt.Dispose e | WStmt.Lookup (_, e) | WStmt.Update (e, _) -> + Some (WExpr.str e) + | _ -> None) + | None -> ( + let open WislLActions in + let* cmd, _ = gil_cmd in + match cmd with + | Cmd.LAction (_, name, [ Expr.BinOp (PVar var, _, _) ]) + when name = str_ac Dispose -> Some var + | Cmd.LAction (_, name, [ _; Expr.BinOp (PVar var, _, _) ]) + when name = str_ac GetCell -> Some var + | _ -> None) + in + let var = Option.value ~default:"" var in + let msg_prefix = msg_prefix var in + match prev_annot with + | None -> Fmt.str "%s in specification" msg_prefix + | Some annot -> ( + let origin_loc = Annot.get_origin_loc annot in + match origin_loc with + | None -> Fmt.str "%s at unknown location" msg_prefix + | Some origin_loc -> + let origin_loc = + Debugger.Utils.location_to_display_location origin_loc + in + Fmt.str "%s at %a" msg_prefix Location.pp origin_loc) + + let get_previously_freed_annot loc = + let annot = Logging.Log_queryer.get_previously_freed_annot loc in + match annot with + | None -> None + | Some annot -> + annot |> Yojson.Safe.from_string |> Annot.of_yojson |> Result.to_option + + let get_missing_resource_var wstmt = + match wstmt with + | Some stmt -> ( + match stmt with + | WStmt.Lookup (_, e) | Update (e, _) -> Some (WExpr.str e) + | _ -> None) + | None -> None + + let get_missing_resource_msg missing_resource_error_info gil_cmd wisl_ast = + let core_pred, loc, offset = missing_resource_error_info in + let default_err_msg = + let prefix = + Fmt.str "Missing %s at location='%s'" + (WislLActions.str_ga core_pred) + loc + in + match offset with + | None -> prefix + | Some offset -> Fmt.str "%s, offset='%a'" prefix Expr.pp offset + in + match wisl_ast with + | None -> default_err_msg + | Some wisl_ast -> ( + match core_pred with + | WislLActions.Cell -> ( + let wstmt = get_wisl_stmt gil_cmd wisl_ast in + let var = get_missing_resource_var wstmt in + match var with + | Some var -> + Fmt.str "Try adding %s -> #new_var to the specification" var + | None -> default_err_msg) + | _ -> default_err_msg) + + let memory_error_to_exception_info info : Debugger.Utils.exception_info = + let id = Fmt.to_to_string WislSMemory.pp_err info.error in + let description = + match info.error with + | WislSHeap.MissingResource missing_resource_error_info -> + Some + (get_missing_resource_msg missing_resource_error_info info.command + info.tl_ast) + | DoubleFree loc -> + let prev_annot = get_previously_freed_annot loc in + let msg_prefix var = Fmt.str "%s already freed" var in + Some + (free_error_to_string msg_prefix prev_annot info.command info.tl_ast) + | UseAfterFree loc -> + let prev_annot = get_previously_freed_annot loc in + let msg_prefix var = Fmt.str "%s freed" var in + Some + (free_error_to_string msg_prefix prev_annot info.command info.tl_ast) + | OutOfBounds (bound, _, _) -> + let var = get_cell_var_from_cmd info.command info.tl_ast in + Some + (Fmt.str "%a is not in bounds %a" (Fmt.option Fmt.string) var + (Fmt.option ~none:(Fmt.any "none") Fmt.int) + bound) + | _ -> None + in + { id; description } + + let add_variables = WislSMemory.add_debugger_variables +end diff --git a/wislfp/lib/debugging/wislLifter.mli b/wislfp/lib/debugging/wislLifter.mli new file mode 100644 index 000000000..d1038738c --- /dev/null +++ b/wislfp/lib/debugging/wislLifter.mli @@ -0,0 +1,12 @@ +open PwSemantics +open Gillian.Debugger + +module Make + (Gil : Gillian.Debugger.Lifter.Gil_fallback_lifter.Gil_lifter_with_state) + (V : Engine.Verifier.S with type annot = PwParserAndCompiler.Annot.t) : + Lifter.S + with type memory_error = PwSemantics.WislSHeap.err + and type tl_ast = PwParserAndCompiler.tl_ast + and type memory = WislSMemory.t + and type cmd_report = V.SAInterpreter.Logging.ConfigReport.t + and type annot = PwParserAndCompiler.Annot.t diff --git a/wislfp/lib/semantics/SFVL.ml b/wislfp/lib/semantics/SFVL.ml new file mode 100644 index 000000000..5e1e8885a --- /dev/null +++ b/wislfp/lib/semantics/SFVL.ml @@ -0,0 +1,118 @@ +(** GIL symbolic field-value list *) + +module Expr = Gillian.Gil_syntax.Expr +module SSubst = Gillian.Symbolic.Subst +open Gillian.Gil_syntax +module L = Gillian.Logging + +type field_name = Expr.t [@@deriving yojson] +type field_value = { value : Expr.t; permission : Expr.t } [@@deriving yojson] + +(* Definition *) +type t = field_value Expr.Map.t [@@deriving yojson] + +let gsbsts = Expr.substitutables + +(* Printing *) +let pp ft sfvl = + let open Fmt in + (iter_bindings ~sep:comma Expr.Map.iter + (hbox (parens (pair ~sep:(any " :") Expr.pp Expr.pp)))) + ft sfvl + +let fv_pp fmt { value; permission } = + Fmt.pf fmt "%a [%a]" Expr.pp value Expr.pp permission + +(*************************************) +(** Field Value List Functions **) + +(*************************************) + +(* Map functions to be reused *) + +let add fn fv = Expr.Map.add fn fv +let empty = Expr.Map.empty + +let field_names sfvl = + let result, _ = List.split (Expr.Map.bindings sfvl) in + result + +let fold f sfvl ac = Expr.Map.fold f sfvl ac +let get fn sfvl = Option.map (fun fv -> fv) (Expr.Map.find_opt fn sfvl) +let is_empty sfvl = sfvl = empty +let iter f sfvl = Expr.Map.iter f sfvl +let partition f sfvl = Expr.Map.partition f sfvl +let remove = Expr.Map.remove + +let union = + Expr.Map.union (fun k (fvl : field_value) (fvr : field_value) -> + L.( + verbose (fun m -> + m + "WARNING: SFVL.union: merging with field in both lists (%s: %s \ + and %s), adding permissions." + ((Fmt.to_to_string Expr.pp) k) + ((Fmt.to_to_string fv_pp) fvl) + ((Fmt.to_to_string fv_pp) fvr))); + let { value; permission = lperm } = fvl in + let { permission = rperm; _ } = fvr in + Some { value; permission = Expr.Infix.(lperm +. rperm) }) + +let to_list fv_list = fold (fun f v ac -> (f, v) :: ac) fv_list [] + +let of_list l = + let add_several l fvl = List.fold_left (fun ac (a, b) -> add a b ac) fvl l in + add_several l empty + +(** Gets a first key-value pair that satisfies a predicate *) +let get_first (f : field_name -> bool) (sfvl : t) : + (field_name * field_value) option = + Expr.Map.find_first_opt f sfvl + +(** Adds by testing something equal is not already there *) +let add_with_test + ~(equality_test : field_name -> field_name -> bool) + (ofs : field_name) + (new_val : field_value) + (sfvl : t) = + let actual_ofs = + Option.value ~default:ofs + (Option.map fst (get_first (equality_test ofs) sfvl)) + in + add actual_ofs new_val sfvl + +(** Returns the logical variables occuring in --sfvl-- *) +let lvars (sfvl : t) : SS.t = + let gllv = Expr.lvars in + Expr.Map.fold + (fun e_field e_val ac -> + ac + |> SS.union (gllv e_field) + |> SS.union (gllv e_val.value) + |> SS.union (gllv e_val.permission)) + sfvl SS.empty + +(** Returns the abstract locations occuring in --sfvl-- *) +let alocs (sfvl : t) : SS.t = + Expr.Map.fold + (fun e_field e_val ac -> + ac + |> SS.union (Expr.alocs e_field) + |> SS.union (Expr.alocs e_val.value) + |> SS.union (Expr.alocs e_val.permission)) + sfvl SS.empty + +(* Substitution *) +let substitution (subst : SSubst.t) (partial : bool) (fv_list : t) : t = + let f_subst = SSubst.subst_in_expr subst ~partial in + Expr.Map.fold + (fun le_field le_val ac -> + let sf = f_subst le_field in + let value = f_subst le_val.value in + let permission = f_subst le_val.permission in + Expr.Map.add sf { value; permission } ac) + fv_list Expr.Map.empty + +let assertions_with_constructor ~constr loc sfvl = + List.rev + (Expr.Map.fold (fun field value ac -> constr loc field value :: ac) sfvl []) diff --git a/wislfp/lib/semantics/constr.ml b/wislfp/lib/semantics/constr.ml new file mode 100644 index 000000000..2562508eb --- /dev/null +++ b/wislfp/lib/semantics/constr.ml @@ -0,0 +1,15 @@ +open WislLActions +open Gil_syntax + +let cell ~loc ~offset ~value ~permission = + let cell = str_ga Cell in + Asrt.GA (cell, [ loc; offset; permission ], [ value ]) + +let bound ~loc ~bound ~permission = + let bound_ga = str_ga Bound in + let bound = Expr.int bound in + Asrt.GA (bound_ga, [ loc; permission ], [ bound ]) + +let freed ~loc = + let freed = str_ga Freed in + Asrt.GA (freed, [ loc ], []) diff --git a/wislfp/lib/semantics/dune b/wislfp/lib/semantics/dune new file mode 100644 index 000000000..701b0681a --- /dev/null +++ b/wislfp/lib/semantics/dune @@ -0,0 +1,6 @@ +(library + (name pwSemantics) + (libraries pwSyntax pwUtils gillian fmt) + (preprocess + (pps ppx_deriving.std ppx_deriving_yojson)) + (flags :standard -open PwUtils -open Utils.Prelude)) diff --git a/wislfp/lib/semantics/wislCHeap.ml b/wislfp/lib/semantics/wislCHeap.ml new file mode 100644 index 000000000..c72a41bd6 --- /dev/null +++ b/wislfp/lib/semantics/wislCHeap.ml @@ -0,0 +1,67 @@ +open Gillian.Concrete +module Literal = Gillian.Gil_syntax.Literal + +type t = (string * int, Values.t) Hashtbl.t + +let init () = Hashtbl.create 1 +let get heap loc offset = Hashtbl.find_opt heap (loc, offset) +let set heap loc offset value = Hashtbl.replace heap (loc, offset) value + +let alloc heap size = + let loc = Gillian.Utils.Generators.fresh_loc () in + let rec aux current_offset = + if current_offset < 0 then () + else + let () = Hashtbl.add heap (loc, current_offset) Literal.Null in + aux (current_offset - 1) + in + let () = aux (size - 1) in + loc + +let remove heap loc offset = Hashtbl.remove heap (loc, offset) + +let dispose heap loc = + Hashtbl.filter_map_inplace + (fun (l, _) v -> if loc = l then None else Some v) + heap + +let load heap loc ofs = Hashtbl.find_opt heap (loc, ofs) +let store heap loc ofs v = Hashtbl.replace heap (loc, ofs) v +let copy heap = Hashtbl.copy heap + +(* small things useful for printing *) + +let rec insert (a, b) l = + match l with + | [] -> [ (a, b) ] + | (x, y) :: r when x < a -> (x, y) :: insert (a, b) r + | l -> (a, b) :: l + +let get_beautiful_list heap = + let add_cell_list (loc, offset) value lis = + let rec aux rest = + match rest with + | [] -> [ (loc, [ (offset, value) ]) ] + | (locp, assocs) :: r when String.equal loc locp -> + (locp, insert (offset, value) assocs) :: r + | a :: r -> a :: aux r + in + aux lis + in + Hashtbl.fold add_cell_list heap [] + +let str heap = + let vstr v = Format.asprintf "%a" Values.pp v in + let one_loc_str loc l = + String.concat "\n" + (List.map + (fun (offset, value) -> + Printf.sprintf "(%s, %i) -> %s" loc offset (vstr value)) + l) + in + let bl = get_beautiful_list heap in + let all_string = + String.concat "\n\n" + (List.map (fun (loc, assocs) -> one_loc_str loc assocs) bl) + in + Printf.sprintf "{\n%s\n}" all_string diff --git a/wislfp/lib/semantics/wislCHeap.mli b/wislfp/lib/semantics/wislCHeap.mli new file mode 100644 index 000000000..7957ed38f --- /dev/null +++ b/wislfp/lib/semantics/wislCHeap.mli @@ -0,0 +1,12 @@ +type t + +val init : unit -> t +val get : t -> string -> int -> Gillian.Concrete.Values.t option +val set : t -> string -> int -> Gillian.Concrete.Values.t -> unit +val alloc : t -> int -> string +val remove : t -> string -> int -> unit +val dispose : t -> string -> unit +val str : t -> string +val copy : t -> t +val load : t -> string -> int -> Gillian.Concrete.Values.t option +val store : t -> string -> int -> Gillian.Concrete.Values.t -> unit diff --git a/wislfp/lib/semantics/wislCMemory.ml b/wislfp/lib/semantics/wislCMemory.ml new file mode 100644 index 000000000..db7ef446b --- /dev/null +++ b/wislfp/lib/semantics/wislCMemory.ml @@ -0,0 +1,121 @@ +open Gillian.Concrete +module Literal = Gillian.Gil_syntax.Literal + +type init_data = unit +type vt = Values.t +type st = Subst.t +type err_t = unit [@@deriving show] +type t = WislCHeap.t +type action_ret = (t * vt list, err_t) result + +let init = WislCHeap.init +let copy = WislCHeap.copy +let pp fmt h = Format.fprintf fmt "%s" (WislCHeap.str h) +let pp_err _fmt () = () + +(* Small util for retrocompat *) +let vstr v = Format.asprintf "%a" Values.pp v + +(* GetCell takes one argument, which supposedly evaluates to a pointer *) +let get_cell heap params = + Literal.( + match params with + | [ Loc loc; Int offset ] -> ( + match WislCHeap.get heap loc (Z.to_int offset) with + | Some value -> Ok (heap, [ Loc loc; Int offset; value ]) + | None -> Error ()) + | l -> + failwith + (Printf.sprintf + "Invalid parameters for Wisl GetCell Local Action : [ %s ] " + (String.concat ", " (List.map vstr l)))) + +let set_cell heap params = + Literal.( + match params with + | [ Loc loc; Int offset; value ] -> + let () = WislCHeap.set heap loc (Z.to_int offset) value in + Ok (heap, []) + | l -> + failwith + (Printf.sprintf + "Invalid parameters for Wisl SetCell Local Action : [ %s ] " + (String.concat ", " (List.map vstr l)))) + +let rem_cell heap params = + Literal.( + match params with + | [ Loc loc; Int offset ] -> + let () = WislCHeap.remove heap loc (Z.to_int offset) in + Ok (heap, []) + | l -> + failwith + (Printf.sprintf + "Invalid parameters for Wisl SetCell Local Action : [ %s ] " + (String.concat ", " (List.map vstr l)))) + +let alloc heap params = + Literal.( + match params with + | [ Int size ] when Z.geq size Z.one -> + let loc = WislCHeap.alloc heap (Z.to_int size) in + let litloc = Loc loc in + Ok (heap, [ litloc; Int Z.zero ]) + (* returns a pointer to the first element *) + | l -> + failwith + (Printf.sprintf + "Invalid parameters for Wisl Alloc Local Action : [ %s ] " + (String.concat ", " (List.map vstr l)))) + +let dispose heap params = + let open Literal in + match params with + | [ Loc obj ] -> + let () = WislCHeap.dispose heap obj in + Ok (heap, []) + | l -> + failwith + (Printf.sprintf + "Invalid parameters for Wisl Dispose Local Action : [ %s ] " + (String.concat ", " (List.map vstr l))) + +let load heap params = + let open Literal in + match params with + | [ Loc loc; Int offset ] -> ( + match WislCHeap.load heap loc (Z.to_int offset) with + | Some value -> Ok (heap, [ value ]) + | None -> Error ()) + | l -> + failwith + (Printf.sprintf + "Invalid parameters for Wisl load local action : [ %s ] " + (String.concat ", " (List.map vstr l))) + +let store heap params = + let open Literal in + match params with + | [ Loc loc; Int offset; value ] -> + let () = WislCHeap.store heap loc (Z.to_int offset) value in + Ok (heap, []) + | l -> + failwith + (Printf.sprintf + "Invalid parameters for Wisl Store Local Action : [ %s ] " + (String.concat ", " (List.map vstr l))) + +let execute_action name heap params = + let action = WislLActions.ac_from_str name in + WislLActions.( + match action with + | GetCell -> get_cell heap params + | SetCell -> set_cell heap params + | RemCell -> rem_cell heap params + | Alloc -> alloc heap params + | Dispose -> dispose heap params + | Load -> load heap params + | Store -> store heap params + | _ -> failwith "Can't use consumer and producers in concrete execution") + +(** Non-implemented functions *) diff --git a/wislfp/lib/semantics/wislCMemory.mli b/wislfp/lib/semantics/wislCMemory.mli new file mode 100644 index 000000000..7484fefd7 --- /dev/null +++ b/wislfp/lib/semantics/wislCMemory.mli @@ -0,0 +1 @@ +include Gillian.Concrete.Memory_S with type init_data = unit diff --git a/wislfp/lib/semantics/wislLActions.ml b/wislfp/lib/semantics/wislLActions.ml new file mode 100644 index 000000000..d44f0e02a --- /dev/null +++ b/wislfp/lib/semantics/wislLActions.ml @@ -0,0 +1,84 @@ +type ac = + | SetCell + | GetCell + | RemCell + | GetFreed + | SetFreed + | RemFreed + | GetBound + | SetBound + | RemBound + | Alloc + | Dispose + | Load + | Store + +type ga = Cell | Bound | Freed [@@deriving yojson, show] + +let str_ac = function + | SetCell -> "setcell" + | GetCell -> "getcell" + | RemCell -> "remcell" + | Alloc -> "alloc" + | Dispose -> "dispose" + | GetFreed -> "getfreed" + | SetFreed -> "setfreed" + | RemFreed -> "remfreed" + | GetBound -> "getbound" + | SetBound -> "setbound" + | RemBound -> "rembound" + | Load -> "load" + | Store -> "store" + +let ac_from_str = function + | "setcell" -> SetCell + | "getcell" -> GetCell + | "remcell" -> RemCell + | "getfreed" -> GetFreed + | "setfreed" -> SetFreed + | "remfreed" -> RemFreed + | "getbound" -> GetBound + | "setbound" -> SetBound + | "rembound" -> RemBound + | "alloc" -> Alloc + | "dispose" -> Dispose + | "load" -> Load + | "store" -> Store + | ac -> failwith ("Unknown local action for wisl : " ^ ac) + +let str_ga = function + | Cell -> "cell" + | Bound -> "bound" + | Freed -> "freed" + +let ga_from_str = function + | "cell" -> Cell + | "bound" -> Bound + | "freed" -> Freed + | ga -> failwith ("Unkown general assertion for wisl : " ^ ga) + +let ga_to_setter = function + | Cell -> SetCell + | Bound -> SetBound + | Freed -> SetFreed + +let ga_to_getter = function + | Cell -> GetCell + | Bound -> GetBound + | Freed -> GetFreed + +let ga_to_deleter = function + | Cell -> RemCell + | Bound -> RemBound + | Freed -> RemFreed + +let ga_to_action_str action str = ga_from_str str |> action |> str_ac +let ga_to_setter_str = ga_to_action_str ga_to_setter +let ga_to_getter_str = ga_to_action_str ga_to_getter +let ga_to_deleter_str = ga_to_action_str ga_to_deleter +let ga_to_yojson x = `String (str_ga x) + +let ga_of_yojson x = + match x with + | `String s -> Ok (ga_from_str s) + | _ -> Error "Invalid json representing wisl core predicate" diff --git a/wislfp/lib/semantics/wislLActions.mli b/wislfp/lib/semantics/wislLActions.mli new file mode 100644 index 000000000..026622a65 --- /dev/null +++ b/wislfp/lib/semantics/wislLActions.mli @@ -0,0 +1,24 @@ +type ac = + | SetCell + | GetCell + | RemCell + | GetFreed + | SetFreed + | RemFreed + | GetBound + | SetBound + | RemBound + | Alloc + | Dispose + | Load + | Store + +type ga = Cell | Bound | Freed [@@deriving yojson, show] + +val str_ac : ac -> string +val ac_from_str : string -> ac +val str_ga : ga -> string +val ga_from_str : string -> ga +val ga_to_setter_str : string -> string +val ga_to_getter_str : string -> string +val ga_to_deleter_str : string -> string diff --git a/wislfp/lib/semantics/wislSHeap.ml b/wislfp/lib/semantics/wislSHeap.ml new file mode 100644 index 000000000..a2c0450e8 --- /dev/null +++ b/wislfp/lib/semantics/wislSHeap.ml @@ -0,0 +1,618 @@ +(***** This module defines a Wisl Symbolic Heap *******) +open Gillian.Symbolic +open Gillian.Gil_syntax +module Solver = Gillian.Logic.FOSolver +module Reduction = Gillian.Logic.Reduction +open Gillian.Debugger.Utils +module PFS = Gillian.Symbolic.Pure_context +module L = Logging + +type err = + | MissingResource of (WislLActions.ga * string * Expr.t option) + | DoubleFree of string + | UseAfterFree of string + | MemoryLeak + | OutOfBounds of (int option * string * Expr.t) + | InvalidLocation +[@@deriving yojson, show] + +module Block = struct + type t = + | Freed + | Allocated of { data : SFVL.t; bound : (int * Expr.t) option } + [@@deriving yojson] + + let empty = Allocated { data = SFVL.empty; bound = None } + + let substitution ~partial subst block = + match block with + | Freed -> Freed + | Allocated { data; bound } -> + let data = SFVL.substitution subst partial data in + let bound = + Option.map + (fun (b, p) -> (b, Subst.subst_in_expr subst ~partial p)) + bound + in + Allocated { data; bound } + + let assertions ~loc block = + let eloc = Expr.loc_from_loc_name loc in + match block with + | Freed -> [ Constr.freed ~loc:eloc ] + | Allocated { data; bound } -> + let data_asrts = + SFVL.assertions_with_constructor + ~constr:(fun loc offset SFVL.{ value; permission } -> + Constr.cell ~loc ~offset ~value ~permission) + eloc data + in + let bound_asrt = + match bound with + | None -> [] + | Some (bound, permission) -> + [ Constr.bound ~loc:eloc ~bound ~permission ] + in + bound_asrt @ data_asrts + + let pp ~loc fmt block = + match block with + | Freed -> Fmt.pf fmt "%s -> FREED" loc + | Allocated { data; bound } -> + Fmt.pf fmt "%s -> @[BOUND: %a@ %a@]" loc + (Fmt.Dump.option (Fmt.Dump.pair Fmt.int Expr.pp)) + bound + (Fmt.braces @@ Fmt.vbox + @@ Fmt.iter_bindings ~sep:Fmt.sp SFVL.iter + @@ fun ft (o, SFVL.{ value; permission }) -> + Fmt.pf ft "%a: %a [%a]" Expr.pp o Expr.pp value Expr.pp permission) + data + + let lvars block = + match block with + | Freed -> SS.empty + | Allocated { data; bound } -> + SS.union (SFVL.lvars data) + (Option.fold ~none:SS.empty ~some:(fun (_, p) -> Expr.lvars p) bound) + + let alocs block = + match block with + | Freed -> SS.empty + | Allocated { data; bound } -> + SS.union (SFVL.alocs data) + (Option.fold ~none:SS.empty ~some:(fun (_, p) -> Expr.alocs p) bound) +end + +type t = (string, Block.t) Hashtbl.t [@@deriving yojson] + +(* A symbolic heap is a map from location and offset to symbolic values *) + +let init () = Hashtbl.create 1 + +(* Simply initializes an empty heap *) + +(****** Standard stuff about hashtbls ********) + +let copy heap = Hashtbl.copy heap + +(****** Types and functions for logging when blocks have been freed ********) + +type set_freed_info = { loc : string } [@@deriving yojson] + +let set_freed_info_pp fmt set_freed = + Fmt.pf fmt "Set Freed at location %s" set_freed.loc + +let set_freed_with_logging heap loc = + let set_freed_info = { loc } in + let _ = + Logging.Specific.normal + (Logging.Loggable.make set_freed_info_pp set_freed_info_of_yojson + set_freed_info_to_yojson set_freed_info) + Logging.Logging_constants.Content_type.set_freed_info + in + Hashtbl.replace heap loc Block.Freed + +(***** Implementation of local actions *****) + +let alloc (heap : t) size = + let loc = ALoc.alloc () in + let rec get_list current_offset = + if current_offset < 0 then [] + else + ( Expr.int current_offset, + SFVL.{ value = Expr.Lit Literal.Null; permission = Lit (Num 1.0) } ) + :: get_list (current_offset - 1) + in + let l = get_list (size - 1) in + let sfvl = SFVL.of_list l in + let block = + Block.Allocated { data = sfvl; bound = Some (size, Lit (Num 1.0)) } + in + let () = Hashtbl.replace heap loc block in + loc + +let dispose ~unification ~pfs ~gamma (heap : t) loc = + match Hashtbl.find_opt heap loc with + | None -> Error (MissingResource (Cell, loc, None)) + | Some Freed -> Error (DoubleFree loc) + | Some (Allocated { data = _; bound = None; _ }) -> + Error (MissingResource (Bound, loc, None)) + | Some (Allocated { data; bound = Some (i, perm) }) -> + let full_perm = Expr.num 1.0 in + let fl q = Formula.Infix.(q#<.full_perm) in + let can_be_less q = + Solver.check_satisfiability ~unification (fl q :: PFS.to_list pfs) gamma + in + if can_be_less perm then Error (MissingResource (Bound, loc, None)) + else + let open Syntaxes.Result in + let check_entry ac i = + let* () = ac in + match SFVL.get (Expr.int i) data with + | None -> Error (MissingResource (Bound, loc, None)) + | Some { permission = q; _ } -> + if can_be_less q then + let missing_permission = Expr.Infix.(full_perm -. q) in + Error (MissingResource (Cell, loc, Some missing_permission)) + else Ok () + in + let+ () = Seq.init i Fun.id |> Seq.fold_left check_entry (Ok ()) in + set_freed_with_logging heap loc + +(* Helper function: Checks if the offset exists in the SFVL first by performing a performance efficient check + and then using the solver. If an entry is found, it applies the success_case function, otherwise the none_case *) +let check_sfvl ~pfs ~gamma ofs data none_case success_case = + let none = + match + SFVL.get_first (fun name -> Solver.is_equal ~pfs ~gamma name ofs) data + with + | None -> none_case () + | Some (o, SFVL.{ value; permission }) -> success_case o value permission + in + let some SFVL.{ value; permission } = success_case ofs value permission in + Option.fold ~none ~some (SFVL.get ofs data) + +(* Helper function: Performs the corresponding correctness checks for a cell assertion + with an optional check for permission accounting, which is useful in the case of producers, + but not for regular load operations. +*) +let access_cell ~unification ~pfs ~gamma heap loc ofs permission_check = + match Hashtbl.find_opt heap loc with + | None -> Error (MissingResource (Cell, loc, Some ofs)) + | Some Block.Freed -> Error (UseAfterFree loc) + | Some (Allocated { data; bound }) -> + let open Syntaxes.Result in + let* () = + match bound with + | None -> Ok () + | Some (n, _) -> + let expr_n = Expr.int n in + let open Formula.Infix in + if Solver.sat ~unification ~pfs ~gamma expr_n #<= ofs then + Error (OutOfBounds (Some n, loc, ofs)) + else Ok () + in + let none_case () = Error (MissingResource (Cell, loc, Some ofs)) in + let success_case ofs value permission = + match permission_check permission with + | Some missing_permission -> + Error (MissingResource (Cell, loc, Some missing_permission)) + | None -> Ok (loc, ofs, value) + in + check_sfvl ~pfs ~gamma ofs data none_case success_case + +let load ~pfs ~gamma heap loc ofs = + let open Syntaxes.Result in + let+ _, _, v = + access_cell ~unification:false ~pfs ~gamma heap loc ofs (fun _ -> None) + in + v + +let get_cell ~unification ~pfs ~gamma heap loc ofs out_perm = + let fl q = Formula.Infix.(q#<.out_perm) in + let permission_check q = + if Solver.check_satisfiability ~unification (fl q :: PFS.to_list pfs) gamma + then Some Expr.Infix.(out_perm -. q) + else None + in + access_cell ~unification ~pfs ~gamma heap loc ofs permission_check + +(* Helper function: Performs the preliminary checks common to the set_cell and store + operations and applies the "block_missing" operation if the block cannot be found + in the heap "in_bounds" operation if the access to the allocated cell is within bounds *) +let overwrite_cell + ~unification + ~pfs + ~gamma + heap + loc_name + ofs + block_missing + in_bounds = + match Hashtbl.find_opt heap loc_name with + | None -> block_missing () + | Some Block.Freed -> Error (UseAfterFree loc_name) + | Some (Allocated { data; bound }) -> ( + match bound with + | None -> in_bounds data None + | Some (n, perm) -> + let expr_n = Expr.int n in + let open Formula.Infix in + if Solver.sat ~unification ~pfs ~gamma expr_n #<= ofs then + Error (MissingResource (Bound, loc_name, Some ofs)) + else in_bounds data (Some (n, perm))) + +(* Helper function: Extends the block data with a new cell at offset ofs with the value v. *) +let extend_block ~pfs ~gamma heap loc_name ofs value data bound permission = + let equality_test = Solver.is_equal ~pfs ~gamma in + let data = + SFVL.add_with_test ~equality_test ofs SFVL.{ value; permission } data + in + let () = Hashtbl.replace heap loc_name (Block.Allocated { data; bound }) in + let fl = Formula.Infix.(permission #>. (Expr.num 0.0)) in + Ok [ fl ] + +let store ~pfs ~gamma heap loc_name ofs v = + let block_missing () = Error (MissingResource (Cell, loc_name, Some ofs)) in + let in_bounds (data : SFVL.t) bound = + let full_perm = Expr.num 1.0 in + let fl q = Formula.Infix.(q#<.full_perm) in + let can_be_less q = + Solver.check_satisfiability (fl q :: PFS.to_list pfs) gamma + in + let none_case () = Error (MissingResource (Cell, loc_name, Some ofs)) in + let some_case ofs _ permission = + if can_be_less permission then + let missing_permission = Expr.Infix.(full_perm -. permission) in + Error (MissingResource (Cell, loc_name, Some missing_permission)) + else extend_block ~pfs ~gamma heap loc_name ofs v data bound permission + in + check_sfvl ~pfs ~gamma ofs data none_case some_case + in + match + overwrite_cell ~unification:false ~pfs ~gamma heap loc_name ofs + block_missing in_bounds + with + | Error e -> Error e + | Ok _ -> Ok () + +let set_cell ~unification ~pfs ~gamma heap loc_name ofs v out_perm = + let block_missing () = + let data = + SFVL.add ofs SFVL.{ value = v; permission = out_perm } SFVL.empty + in + let bound = None in + let () = Hashtbl.replace heap loc_name (Block.Allocated { data; bound }) in + Ok [] + in + let in_bounds data bound = + let full_perm = Expr.num 1.0 in + let none_case () = + extend_block ~pfs ~gamma heap loc_name ofs v data bound out_perm + in + let some_case _ value permission = + let eq = Formula.Infix.(value #== v) in + let new_perm = Expr.Infix.(permission +. out_perm) in + let fl = Formula.Infix.(new_perm#<=.full_perm) in + let () = + Hashtbl.replace heap loc_name (Block.Allocated { data; bound }) + in + Ok [ eq; fl ] + in + check_sfvl ~pfs ~gamma ofs data none_case some_case + in + overwrite_cell ~unification ~pfs ~gamma heap loc_name ofs block_missing + in_bounds + +let rem_cell ~pfs ~gamma heap loc offset out_perm = + match Hashtbl.find_opt heap loc with + | None -> Error (MissingResource (Cell, loc, Some offset)) + | Some Block.Freed -> Error (UseAfterFree loc) + | Some (Allocated { data; bound }) -> ( + match SFVL.get offset data with + | None -> + failwith + "Called rem_cell with an offset that is not in the data SFVL!" + | Some SFVL.{ value; permission } -> + let data = SFVL.remove offset data in + let new_perm = Expr.Infix.(permission -. out_perm) in + let data = + if Solver.is_equal ~pfs ~gamma new_perm (Expr.num 0.0) then data + else SFVL.add offset SFVL.{ value; permission = new_perm } data + in + let () = Hashtbl.replace heap loc (Allocated { data; bound }) in + Ok ()) + +let get_bound ~unification ~pfs ~gamma heap loc out_perm = + match Hashtbl.find_opt heap loc with + | Some Block.Freed -> Error (UseAfterFree loc) + | None -> Error (MissingResource (Cell, loc, None)) + | Some (Allocated { bound = None; _ }) -> + Error (MissingResource (Bound, loc, None)) + | Some (Allocated { bound = Some bound; _ }) -> + let _, q = bound in + let fl = Formula.Infix.(q#<.out_perm) in + let has_less_perm = + Solver.check_satisfiability ~unification (fl :: PFS.to_list pfs) gamma + in + if has_less_perm then + let missing_permission = Expr.Infix.(out_perm -. q) in + Error (MissingResource (Bound, loc, Some missing_permission)) + else Ok bound + +let set_bound heap loc b out_perm = + let prev = Option.value ~default:Block.empty (Hashtbl.find_opt heap loc) in + match prev with + | Freed -> Error (UseAfterFree loc) + | Allocated { data; bound } -> ( + match bound with + | None -> + let () = + Hashtbl.replace heap loc + (Block.Allocated { data; bound = Some (b, out_perm) }) + in + Ok [] + | Some (_, permission) -> + let full_perm = Expr.num 1.0 in + let new_perm = Expr.Infix.(permission +. out_perm) in + let fl = Formula.Infix.(new_perm#<=.full_perm) in + let () = + Hashtbl.replace heap loc + (Block.Allocated { data; bound = Some (b, new_perm) }) + in + Ok [ fl ]) + +let rem_bound ~pfs ~gamma heap loc out_perm = + match Hashtbl.find_opt heap loc with + | Some Block.Freed -> Error (UseAfterFree loc) + | None -> Error (MissingResource (Cell, loc, None)) + | Some (Allocated { bound = None; _ }) -> + Error (MissingResource (Bound, loc, None)) + | Some (Allocated { data; bound = Some (n, q) }) -> + let new_perm = Expr.Infix.(q -. out_perm) in + let bound = + if Solver.is_equal ~pfs ~gamma new_perm (Expr.num 0.0) then None + else Some (n, new_perm) + in + let () = Hashtbl.replace heap loc (Allocated { data; bound }) in + Ok () + +let get_freed heap loc = + match Hashtbl.find_opt heap loc with + | Some Block.Freed -> Ok () + | Some _ -> Error MemoryLeak + | None -> Error (MissingResource (Freed, loc, None)) + +let set_freed heap loc = set_freed_with_logging heap loc + +let rem_freed heap loc = + match Hashtbl.find_opt heap loc with + | Some Block.Freed -> + Hashtbl.remove heap loc; + Ok () + | None -> Error (MissingResource (Freed, loc, None)) + | Some _ -> Error MemoryLeak + +(***** Some things specific to symbolic heaps ********) + +let merge_loc (heap : t) new_loc old_loc : unit = + let old_block, new_block = + (Hashtbl.find_opt heap old_loc, Hashtbl.find_opt heap new_loc) + in + match (old_block, new_block) with + | Some Block.Freed, Some Block.Freed -> Hashtbl.remove heap old_loc + | None, Some Block.Freed -> () + | Some Block.Freed, None -> + Hashtbl.replace heap new_loc Block.Freed; + Hashtbl.remove heap old_loc + | _, _ -> ( + let old_block = Option.value ~default:Block.empty old_block in + let new_block = Option.value ~default:Block.empty new_block in + match (old_block, new_block) with + | _, Freed | Freed, _ -> failwith "merging non-freed and freed block" + | ( Allocated { data = old_data; bound = old_bound }, + Allocated { data = new_data; bound = new_bound } ) -> + let data = SFVL.union new_data old_data in + let bound = + if Option.is_some new_bound then new_bound else old_bound + in + let () = Hashtbl.replace heap new_loc (Allocated { data; bound }) in + Hashtbl.remove heap old_loc) + +let substitution_in_place subst heap : + (t * Formula.Set.t * (string * Type.t) list) list = + (* First we replace in the offset and values using fvl *) + let () = + Hashtbl.iter + (fun loc block -> + Hashtbl.replace heap loc (Block.substitution ~partial:true subst block)) + heap + in + (* Then we replace within the locations themselves *) + let aloc_subst = + Subst.filter subst (fun var _ -> + match var with + | ALoc _ -> true + | _ -> false) + in + Subst.iter aloc_subst (fun aloc new_loc -> + let aloc = + match aloc with + | ALoc loc -> loc + | _ -> raise (Failure "Impossible by construction") + in + let new_loc_str = + match new_loc with + | Expr.Lit (Literal.Loc loc) -> loc + | Expr.ALoc loc -> loc + | _ -> + raise + (Failure + (Printf.sprintf "Heap substitution fail for loc: %s" + ((WPrettyUtils.to_str Expr.pp) new_loc))) + in + merge_loc heap new_loc_str aloc); + [ (heap, Formula.Set.empty, []) ] + +let assertions heap = + Hashtbl.fold (fun loc block acc -> Block.assertions ~loc block @ acc) heap [] + +let lvars heap : SS.t = + Hashtbl.fold + (fun _ block acc -> SS.union (Block.lvars block) acc) + heap SS.empty + +let alocs heap : SS.t = + Hashtbl.fold + (fun loc block acc -> + SS.union + (SS.union (Block.alocs block) acc) + (match Gillian.Utils.Names.is_aloc_name loc with + | true -> SS.singleton loc + | false -> SS.empty)) + heap SS.empty + +(***** small things useful for printing ******) + +let pp fmt heap = + Fmt.pf fmt "@[%a@]" + ( Fmt.iter_bindings ~sep:(Fmt.any "@\n@\n") Hashtbl.iter @@ fun ft (l, b) -> + Block.pp ~loc:l ft b ) + heap + +let get_store_vars store is_gil_file = + List.filter_map + (fun (var, (value : Gil_syntax.Expr.t)) -> + if (not is_gil_file) && Str.string_match (Str.regexp "gvar") var 0 then + None + else + let match_offset lst loc loc_pp = + match lst with + | [ Expr.Lit (Int offset) ] -> + Fmt.str "-> (%a, %d)" (Fmt.hbox loc_pp) loc (Z.to_int offset) + | [ offset ] -> + Fmt.str "-> (%a, %a)" (Fmt.hbox loc_pp) loc (Fmt.hbox Expr.pp) + offset + | _ -> Fmt.to_to_string (Fmt.hbox Expr.pp) value + in + let value = + match value with + | Expr.EList (Lit (Loc loc) :: rest) | Expr.EList (LVar loc :: rest) + -> match_offset rest loc Fmt.string + | _ -> Fmt.to_to_string (Fmt.hbox Expr.pp) value + in + Some ({ name = var; value; type_ = None; var_ref = 0 } : Variable.t)) + store + |> List.sort Stdlib.compare + +let add_memory_vars (smemory : t) (get_new_scope_id : unit -> int) variables : + Variable.t list = + let vstr = Fmt.to_to_string (Fmt.hbox Expr.pp) in + let compare_offsets (v, _) (w, _) = + try + let open Expr.Infix in + let difference = v - w in + match difference with + | Expr.Lit (Int f) -> + if Z.lt f Z.zero then -1 else if Z.gt f Z.zero then 1 else 0 + | _ -> 0 + with _ -> (* Do not sort the offsets if an exception has occurred *) + 0 + in + let cell_vars l : Variable.t list = + List.sort compare_offsets l + |> List.map (fun (offset, SFVL.{ value; _ }) : Variable.t -> + (* Display offset as a number to match the printing of WISL pointers *) + let offset_str = + match offset with + | Expr.Lit (Int o) -> Z.to_string o + | other -> vstr other + in + Variable.create_leaf offset_str (vstr value) ()) + in + smemory |> Hashtbl.to_seq + |> Seq.map (fun (loc, blocks) -> + match blocks with + | Block.Freed -> Variable.create_leaf loc "freed" () + | Allocated { data; bound } -> + let bound = + match bound with + | None -> "none" + | Some (n, _) -> string_of_int n + in + let bound = Variable.create_leaf "bound" bound () in + let cells_id = get_new_scope_id () in + let () = + Hashtbl.replace variables cells_id + (cell_vars (SFVL.to_list data)) + in + let cells = Variable.create_node "cells" cells_id () in + let loc_id = get_new_scope_id () in + let () = Hashtbl.replace variables loc_id [ bound; cells ] in + Variable.create_node loc loc_id ~value:"allocated" ()) + |> List.of_seq + +let add_debugger_variables + ~store + ~memory + ~is_gil_file + ~get_new_scope_id + variables = + let store_id = get_new_scope_id () in + let memory_id = get_new_scope_id () in + let scopes : Variable.scope list = + [ { id = store_id; name = "Store" }; { id = memory_id; name = "Memory" } ] + in + let store_vars = get_store_vars store is_gil_file in + let memory_vars = add_memory_vars memory get_new_scope_id variables in + let vars = [ store_vars; memory_vars ] in + let () = + List.iter2 + (fun (scope : Variable.scope) vars -> + Hashtbl.replace variables scope.id vars) + scopes vars + in + scopes + +(***** Clean-up *****) + +let clean_up (keep : Expr.Set.t) (heap : t) : Expr.Set.t * Expr.Set.t = + let forgettables = + Hashtbl.fold + (fun (aloc : string) (block : Block.t) forgettables -> + match block with + | Freed -> forgettables + | Allocated { data; bound; _ } -> ( + match + (SFVL.is_empty data, bound, Expr.Set.mem (ALoc aloc) keep) + with + | true, None, false -> + let () = Hashtbl.remove heap aloc in + Expr.Set.add (Expr.ALoc aloc) forgettables + | _ -> forgettables)) + heap Expr.Set.empty + in + let keep = + Hashtbl.fold + (fun (aloc : string) (block : Block.t) keep -> + let keep = Expr.Set.add (ALoc aloc) keep in + match block with + | Freed -> keep + | Allocated { data; _ } -> + let data_alocs = + Expr.Set.of_list + (List.map + (fun x -> Expr.ALoc x) + (SS.elements (SFVL.alocs data))) + in + let data_lvars = + Expr.Set.of_list + (List.map + (fun x -> Expr.LVar x) + (SS.elements (SFVL.lvars data))) + in + Expr.Set.union keep (Expr.Set.union data_alocs data_lvars)) + heap keep + in + let forgettables = Expr.Set.diff forgettables keep in + (forgettables, keep) diff --git a/wislfp/lib/semantics/wislSHeap.mli b/wislfp/lib/semantics/wislSHeap.mli new file mode 100644 index 000000000..a85b0563f --- /dev/null +++ b/wislfp/lib/semantics/wislSHeap.mli @@ -0,0 +1,119 @@ +open Gillian.Symbolic +open Gil_syntax +open Gillian.Debugger.Utils + +type t [@@deriving yojson] + +type err = + | MissingResource of (WislLActions.ga * string * Expr.t option) + | DoubleFree of string + | UseAfterFree of string + | MemoryLeak + | OutOfBounds of (int option * string * Expr.t) + | InvalidLocation +[@@deriving yojson, show] + +val init : unit -> t +val alloc : t -> int -> string + +val dispose : + unification:bool -> + pfs:Pure_context.t -> + gamma:Type_env.t -> + t -> + string -> + (unit, err) Result.t + +val clean_up : Expr.Set.t -> t -> Expr.Set.t * Expr.Set.t + +val load : + pfs:Pure_context.t -> + gamma:Type_env.t -> + t -> + string -> + Expr.t -> + (Expr.t, err) result + +val store : + pfs:Pure_context.t -> + gamma:Type_env.t -> + t -> + string -> + Expr.t -> + Expr.t -> + (unit, err) result + +val get_cell : + unification:bool -> + pfs:Pure_context.t -> + gamma:Type_env.t -> + t -> + string -> + Expr.t -> + Expr.t -> + (string * Expr.t * Expr.t, err) result + +val set_cell : + unification:bool -> + pfs:Pure_context.t -> + gamma:Type_env.t -> + t -> + string -> + Expr.t -> + Expr.t -> + Expr.t -> + (Formula.t list, err) result + +val rem_cell : + pfs:Pure_context.t -> + gamma:Type_env.t -> + t -> + string -> + Expr.t -> + Expr.t -> + (unit, err) result + +val get_bound : + unification:bool -> + pfs:Pure_context.t -> + gamma:Type_env.t -> + t -> + string -> + Expr.t -> + (int * Expr.t, err) result + +val set_bound : t -> string -> int -> Expr.t -> (Formula.t list, err) result + +val rem_bound : + pfs:Pure_context.t -> + gamma:Type_env.t -> + t -> + string -> + Expr.t -> + (unit, err) result + +val get_freed : t -> string -> (unit, err) result +val set_freed : t -> string -> unit +val rem_freed : t -> string -> (unit, err) result +val pp : t Fmt.t +val copy : t -> t +val lvars : t -> SS.t +val alocs : t -> SS.t + +val substitution_in_place : + Gillian.Symbolic.Subst.t -> + t -> + (t + * Gillian.Gil_syntax.Formula.Set.t + * (string * Gillian.Gil_syntax.Type.t) list) + list + +val assertions : t -> Gillian.Gil_syntax.Asrt.t list + +val add_debugger_variables : + store:(string * Gillian.Gil_syntax.Expr.t) list -> + memory:t -> + is_gil_file:bool -> + get_new_scope_id:(unit -> int) -> + Variable.ts -> + Variable.scope list diff --git a/wislfp/lib/semantics/wislSMemory.ml b/wislfp/lib/semantics/wislSMemory.ml new file mode 100644 index 000000000..00d91cbc8 --- /dev/null +++ b/wislfp/lib/semantics/wislSMemory.ml @@ -0,0 +1,379 @@ +open Gillian.Symbolic +open Gillian.Gil_syntax +open Gillian.Logic +module Recovery_tactic = Gillian.General.Recovery_tactic +module Logging = Gillian.Logging +module SFVL = SFVL +module SS = Gillian.Utils.Containers.SS + +type init_data = unit +type vt = Values.t +type st = Subst.t +type err_t = WislSHeap.err [@@deriving yojson, show] +type c_fix_t = unit +type t = WislSHeap.t [@@deriving yojson] + +type action_ret = + ( (t * vt list * Formula.t list * (string * Type.t) list) list, + err_t list ) + result + +let init () = WislSHeap.init () +let clear _ = WislSHeap.init () + +let resolve_loc pfs gamma loc = + Gillian.Logic.FOSolver.resolve_loc_name ~pfs ~gamma loc + +let overwrite_cell pfs gamma (loc : vt) action = + let loc_name, new_pfs = + (* If we can't find the location, we create a new location and we + add to the path condition that it is equal to the given loc *) + let resolved_loc_opt = resolve_loc pfs gamma loc in + match resolved_loc_opt with + | Some loc_name -> + if Gillian.Utils.Names.is_aloc_name loc_name then (loc_name, []) + else (loc_name, []) + | None -> + let al = ALoc.alloc () in + (al, [ Formula.Eq (Expr.ALoc al, loc) ]) + in + action new_pfs loc_name + +let store heap pfs gamma (loc : vt) (offset : vt) (value : vt) = + let action new_pfs loc_name = + match WislSHeap.store ~pfs ~gamma heap loc_name offset value with + | Error e -> Error [ e ] + | Ok () -> Ok [ (heap, [], new_pfs, []) ] + in + overwrite_cell pfs gamma loc action + +let load heap pfs gamma (loc : vt) (offset : vt) = + match FOSolver.resolve_loc_name ~pfs ~gamma loc with + | None -> Error [ WislSHeap.InvalidLocation ] + | Some loc -> ( + match WislSHeap.load ~pfs ~gamma heap loc offset with + | Error err -> Error [ err ] + | Ok value -> Ok [ (heap, [ value ], [], []) ]) + +let get_cell ~unification heap pfs gamma (loc : vt) (offset : vt) permission = + match resolve_loc pfs gamma loc with + | None -> Error [ WislSHeap.InvalidLocation ] + | Some loc -> ( + match + WislSHeap.get_cell ~unification ~pfs ~gamma heap loc offset permission + with + | Error err -> Error [ err ] + | Ok (loc, ofs, value) -> + let loc = Expr.loc_from_loc_name loc in + Ok [ (heap, [ loc; ofs; permission; value ], [], []) ]) + +let set_cell + ~unification + heap + pfs + gamma + (loc : vt) + (offset : vt) + (value : vt) + permission = + let action new_pfs loc_name = + match + WislSHeap.set_cell ~unification ~pfs ~gamma heap loc_name offset value + permission + with + | Error e -> Error [ e ] + | Ok fls -> Ok [ (heap, [], fls @ new_pfs, []) ] + in + overwrite_cell pfs gamma loc action + +let rem_cell heap pfs gamma (loc : vt) (offset : vt) permission = + match FOSolver.resolve_loc_name ~pfs ~gamma loc with + | Some loc_name -> ( + match WislSHeap.rem_cell ~pfs ~gamma heap loc_name offset permission with + | Error e -> Error [ e ] + | Ok () -> Ok [ (heap, [], [], []) ]) + | None -> + (* loc does not evaluate to a location, or we can't find it. *) + Error [ InvalidLocation ] + +let get_bound ~unification heap pfs gamma loc permission = + match FOSolver.resolve_loc_name ~pfs ~gamma loc with + | Some loc_name -> ( + match + WislSHeap.get_bound ~unification ~pfs ~gamma heap loc_name permission + with + | Error e -> Error [ e ] + | Ok (b, perm) -> + let b = Expr.int b in + let loc = Expr.loc_from_loc_name loc_name in + Ok [ (heap, [ loc; perm; b ], [], []) ]) + | None -> Error [ InvalidLocation ] + +let set_bound heap pfs gamma (loc : vt) (bound : int) permission = + let loc_name, new_pfs = + (* If we can't find the location, we create a new location and we + add to the path condition that it is equal to the given loc *) + let resolved_loc_opt = resolve_loc pfs gamma loc in + match resolved_loc_opt with + | Some loc_name -> + if Gillian.Utils.Names.is_aloc_name loc_name then (loc_name, []) + else (loc_name, []) + | None -> + let al = ALoc.alloc () in + (al, [ Formula.Eq (Expr.ALoc al, loc) ]) + in + match WislSHeap.set_bound heap loc_name bound permission with + | Error e -> Error [ e ] + | Ok fls -> Ok [ (heap, [], fls @ new_pfs, []) ] + +let rem_bound heap pfs gamma loc permission = + match FOSolver.resolve_loc_name ~pfs ~gamma loc with + | Some loc_name -> ( + match WislSHeap.rem_bound ~pfs ~gamma heap loc_name permission with + | Error e -> Error [ e ] + | Ok () -> Ok [ (heap, [], [], []) ]) + | None -> + (* loc does not evaluate to a location, or we can't find it. *) + Error [ InvalidLocation ] + +let get_freed heap pfs gamma loc = + match FOSolver.resolve_loc_name ~pfs ~gamma loc with + | Some loc_name -> ( + match WislSHeap.get_freed heap loc_name with + | Error e -> Error [ e ] + | Ok () -> + let loc = Expr.loc_from_loc_name loc_name in + Ok [ (heap, [ loc ], [], []) ]) + | None -> Error [ InvalidLocation ] + +let set_freed heap pfs gamma (loc : vt) = + let loc_name, new_pfs = + (* If we can't find the location, we create a new location and we + add to the path condition that it is equal to the given loc *) + let resolved_loc_opt = resolve_loc pfs gamma loc in + match resolved_loc_opt with + | Some loc_name -> + if Gillian.Utils.Names.is_aloc_name loc_name then (loc_name, []) + else (loc_name, []) + | None -> + let al = ALoc.alloc () in + (al, [ Formula.Eq (Expr.ALoc al, loc) ]) + in + let () = WislSHeap.set_freed heap loc_name in + Ok [ (heap, [], new_pfs, []) ] + +let rem_freed heap pfs gamma loc = + match FOSolver.resolve_loc_name ~pfs ~gamma loc with + | Some loc_name -> ( + match WislSHeap.rem_freed heap loc_name with + | Error e -> Error [ e ] + | Ok () -> Ok [ (heap, [], [], []) ]) + | None -> + (* loc does not evaluate to a location, or we can't find it. *) + Error [ InvalidLocation ] + +let alloc heap _pfs _gamma (size : int) = + let loc = WislSHeap.alloc heap size in + Ok [ (heap, [ Expr.ALoc loc; Expr.Lit (Literal.Int Z.zero) ], [], []) ] + +let dispose ~unification heap pfs gamma loc_expr = + match resolve_loc pfs gamma loc_expr with + | Some loc_name -> ( + match WislSHeap.dispose ~unification heap ~pfs ~gamma loc_name with + | Ok () -> Ok [ (heap, [], [], []) ] + | Error e -> Error [ e ]) + | None -> Error [ InvalidLocation ] + +let execute_action ?(unification = false) name heap pfs gamma args = + let action = WislLActions.ac_from_str name in + let ret = + match action with + | Store -> ( + match args with + | [ loc_expr; offset_expr; value_expr ] -> + store heap pfs gamma loc_expr offset_expr value_expr + | args -> + failwith + (Format.asprintf + "Invalid Store Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | Load -> ( + match args with + | [ loc_expr; offset_expr ] -> load heap pfs gamma loc_expr offset_expr + | args -> + failwith + (Format.asprintf + "Invalid Load Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | GetCell -> ( + match args with + | [ loc_expr; offset_expr; permission ] -> + get_cell ~unification heap pfs gamma loc_expr offset_expr permission + | args -> + failwith + (Format.asprintf + "Invalid GetCell Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | SetCell -> ( + match args with + | [ loc_expr; offset_expr; permission; value_expr ] -> + set_cell ~unification heap pfs gamma loc_expr offset_expr value_expr + permission + | args -> + failwith + (Format.asprintf + "Invalid SetCell Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | RemCell -> ( + match args with + | [ loc_expr; offset_expr; permission ] -> + rem_cell heap pfs gamma loc_expr offset_expr permission + | args -> + failwith + (Format.asprintf + "Invalid RemCell Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | GetBound -> ( + match args with + | [ loc_expr; permission ] -> + get_bound ~unification heap pfs gamma loc_expr permission + | args -> + failwith + (Format.asprintf + "Invalid GetBound Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | SetBound -> ( + match args with + | [ loc_expr; permission; Expr.Lit (Int b) ] -> + set_bound heap pfs gamma loc_expr (Z.to_int b) permission + | args -> + failwith + (Format.asprintf + "Invalid SetBound Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | RemBound -> ( + match args with + | [ loc_expr; permission ] -> + rem_bound heap pfs gamma loc_expr permission + | args -> + failwith + (Format.asprintf + "Invalid RemBound Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | GetFreed -> ( + match args with + | [ loc_expr ] -> get_freed heap pfs gamma loc_expr + | args -> + failwith + (Format.asprintf + "Invalid GetFreed Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | SetFreed -> ( + match args with + | [ loc_expr ] -> set_freed heap pfs gamma loc_expr + | args -> + failwith + (Format.asprintf + "Invalid SetFreed Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | RemFreed -> ( + match args with + | [ loc_expr ] -> rem_freed heap pfs gamma loc_expr + | args -> + failwith + (Format.asprintf + "Invalid RemFreed Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | Alloc -> ( + match args with + | [ Expr.Lit (Literal.Int size) ] when Z.geq size Z.one -> + alloc heap pfs gamma (Z.to_int size) + | args -> + failwith + (Format.asprintf + "Invalid Alloc Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + | Dispose -> ( + match args with + | [ loc_expr ] -> dispose ~unification heap pfs gamma loc_expr + | args -> + failwith + (Format.asprintf + "Invalid Dispose Call for WISL, with parameters : [ %a ]" + (WPrettyUtils.pp_list ~sep:(format_of_string "; ") Values.pp) + args)) + in + Logging.verbose (fun m -> + m "Action %s resulted in %a" + (WislLActions.str_ac action) + Fmt.( + result + ~ok: + (Dump.list (fun ft (h, vs, fs, tys) -> + pf ft "(%a, %a, %a, %a)" WislSHeap.pp h (Dump.list Expr.pp) + vs (Dump.list Formula.pp) fs + (Dump.list @@ Dump.pair string Type.pp) + tys)) + ~error:(Dump.list WislSHeap.pp_err)) + ret); + ret + +let ga_to_setter = WislLActions.ga_to_setter_str +let ga_to_getter = WislLActions.ga_to_getter_str +let ga_to_deleter = WislLActions.ga_to_deleter_str +let copy = WislSHeap.copy +let pp fmt h = Format.fprintf fmt "%a" WislSHeap.pp h + +(* TODO: Implement properly *) +let pp_by_need _ fmt h = pp fmt h + +(* TODO: Implement properly *) +let get_print_info _ _ = (SS.empty, SS.empty) + +let pp_err fmt t = + Fmt.string fmt + (match t with + | WislSHeap.MissingResource _ -> "Missing Resource" + | DoubleFree _ -> "Double Free" + | UseAfterFree _ -> "Use After Free" + | MemoryLeak -> "Memory Leak" + | OutOfBounds _ -> "Out Of Bounds" + | InvalidLocation -> "Invalid Location") + +let pp_c_fix _ _ = () +let substitution_in_place ~pfs:_ ~gamma:_ = WislSHeap.substitution_in_place +let fresh_val _ = Expr.LVar (LVar.alloc ()) + +let clean_up ?(keep = Expr.Set.empty) (mem : t) : Expr.Set.t * Expr.Set.t = + WislSHeap.clean_up keep mem + +let lvars heap = WislSHeap.lvars heap +let alocs heap = WislSHeap.alocs heap +let assertions ?to_keep:_ heap = WislSHeap.assertions heap +let mem_constraints _ = [] +let is_overlapping_asrt _ = false +let apply_fix m _ _ _ = m +let get_fixes _ _ _ _ = [] + +let get_recovery_tactic _ e = + match e with + | WislSHeap.MissingResource (_, loc, ofs) -> + let loc = Expr.loc_from_loc_name loc in + let ofs = Option.to_list ofs in + Recovery_tactic.try_unfold (loc :: ofs) + | _ -> Recovery_tactic.none + +let get_failing_constraint _ = Formula.True +let add_debugger_variables = WislSHeap.add_debugger_variables diff --git a/wislfp/lib/semantics/wislSMemory.mli b/wislfp/lib/semantics/wislSMemory.mli new file mode 100644 index 000000000..63553eead --- /dev/null +++ b/wislfp/lib/semantics/wislSMemory.mli @@ -0,0 +1,14 @@ +open Gillian.Debugger.Utils + +include + Gillian.Symbolic.Legacy_s_memory.S + with type err_t = WislSHeap.err + and type init_data = unit + +val add_debugger_variables : + store:(string * Gillian.Gil_syntax.Expr.t) list -> + memory:t -> + is_gil_file:bool -> + get_new_scope_id:(unit -> int) -> + Variable.ts -> + Variable.scope list diff --git a/wislfp/lib/syntax/WBinOp.ml b/wislfp/lib/syntax/WBinOp.ml new file mode 100644 index 000000000..d156d4cb8 --- /dev/null +++ b/wislfp/lib/syntax/WBinOp.ml @@ -0,0 +1,66 @@ +type t = + | NEQ + | EQUAL + | LESSTHAN + | FLESSTHAN + | GREATERTHAN + | FGREATERTHAN + | LESSEQUAL + | FLESSEQUAL + | GREATEREQUAL + | FGREATEREQUAL + | PLUS + | FPLUS + | MINUS + | FMINUS + | TIMES + | FTIMES + | DIV + | FDIV + | MOD + | FMOD + | AND + | OR + (* Lists are only for the logic *) + | LSTCONS + (* list construction a::l, only for logic *) + | LSTCAT + | LSTNTH + +(* list concatenation, only for logic *) + +let pp fmt b = + let s = Format.fprintf fmt "@[%s@]" in + match b with + | EQUAL -> s "=" + | LESSTHAN -> s "<" + | FLESSTHAN -> s "f<" + | GREATERTHAN -> s ">" + | FGREATERTHAN -> s "f>" + | LESSEQUAL -> s "<=" + | FLESSEQUAL -> s "f<=" + | GREATEREQUAL -> s ">=" + | FGREATEREQUAL -> s "f>=" + | PLUS -> s "+" + | FPLUS -> s "f+" + | MINUS -> s "-" + | FMINUS -> s "f-" + | TIMES -> s "*" + | FTIMES -> s "f*" + | DIV -> s "/" + | FDIV -> s "f/" + | MOD -> s "%" + | FMOD -> s "f%" + | AND -> s "&&" + | OR -> s "||" + | NEQ -> s "!=" + | LSTCAT -> s "@" + | LSTCONS -> s "::" + | LSTNTH -> s "lnth" + +let str = Format.asprintf "%a" pp + +let is_logic_only b = + match b with + | LSTCONS | LSTCAT -> true + | _ -> false diff --git a/wislfp/lib/syntax/WBinOp.mli b/wislfp/lib/syntax/WBinOp.mli new file mode 100644 index 000000000..0b52d5180 --- /dev/null +++ b/wislfp/lib/syntax/WBinOp.mli @@ -0,0 +1,34 @@ +type t = + | NEQ + | EQUAL + | LESSTHAN + | FLESSTHAN + | GREATERTHAN + | FGREATERTHAN + | LESSEQUAL + | FLESSEQUAL + | GREATEREQUAL + | FGREATEREQUAL + | PLUS + | FPLUS + | MINUS + | FMINUS + | TIMES + | FTIMES + | DIV + | FDIV + | MOD + | FMOD + | AND + | OR + (* Lists are only for the logic *) + | LSTCONS + (* list construction a::l, only for logic *) + | LSTCAT + | LSTNTH + +(* list concatenation, only for logic *) + +val pp : Format.formatter -> t -> unit +val str : t -> string +val is_logic_only : t -> bool diff --git a/wislfp/lib/syntax/WExpr.ml b/wislfp/lib/syntax/WExpr.ml new file mode 100644 index 000000000..c50232ecb --- /dev/null +++ b/wislfp/lib/syntax/WExpr.ml @@ -0,0 +1,43 @@ +open VisitorUtils + +type tt = + | Val of WVal.t + | Var of string + | BinOp of t * WBinOp.t * t + | UnOp of WUnOp.t * t + | List of t list + +and t = { weid : int; weloc : CodeLoc.t; wenode : tt } + +let get e = e.wenode +let get_loc e = e.weloc +let get_id e = e.weid + +let make bare_expr loc = + { weid = Generators.gen_id (); weloc = loc; wenode = bare_expr } + +let rec get_by_id id e = + let getter = get_by_id id in + let aux ep = + match get ep with + | BinOp (e1, _, e2) -> getter e1 |>> (getter, e2) + | UnOp (_, epp) -> getter epp + | _ -> `None + in + let self_or_none = if get_id e = id then `WExpr e else `None in + self_or_none |>> (aux, e) + +let rec pp fmt e = + match get e with + | Val v -> WVal.pp fmt v + | Var s -> Format.fprintf fmt "@[%s@]" s + | List el -> + WPrettyUtils.pp_list ~pre:(format_of_string "@[[") + ~suf:(format_of_string "]@]") + ~empty:(format_of_string "@[nil@]") + pp fmt el + | BinOp (e1, b, e2) -> + Format.fprintf fmt "@[%a@ %a@ %a@]" pp e1 WBinOp.pp b pp e2 + | UnOp (u, e) -> Format.fprintf fmt "@[%a@ %a@]" WUnOp.pp u pp e + +let str = Format.asprintf "%a" pp diff --git a/wislfp/lib/syntax/WExpr.mli b/wislfp/lib/syntax/WExpr.mli new file mode 100644 index 000000000..e16da88b4 --- /dev/null +++ b/wislfp/lib/syntax/WExpr.mli @@ -0,0 +1,16 @@ +type tt = + | Val of WVal.t + | Var of string + | BinOp of t * WBinOp.t * t + | UnOp of WUnOp.t * t + | List of t list + +and t + +val get : t -> tt +val get_loc : t -> CodeLoc.t +val get_id : t -> int +val make : tt -> CodeLoc.t -> t +val get_by_id : int -> t -> [> `None | `WExpr of t ] +val pp : Format.formatter -> t -> unit +val str : t -> string diff --git a/wislfp/lib/syntax/WFun.ml b/wislfp/lib/syntax/WFun.ml new file mode 100644 index 000000000..e77f82018 --- /dev/null +++ b/wislfp/lib/syntax/WFun.ml @@ -0,0 +1,58 @@ +open VisitorUtils + +type t = { + name : string; + params : string list; + body : WStmt.t list; + spec : WSpec.t option; + return_expr : WExpr.t; + floc : CodeLoc.t; + fid : int; + is_loop_body : bool; +} + +let get_id f = f.fid +let get_loc f = f.floc +let get_name f = f.name +let get_spec f = f.spec + +let add_spec ?existentials f pre post variant loc = + let spec = WSpec.make ?existentials pre post variant f.name f.params loc in + { f with spec = Some spec; floc = loc } + +let functions_called f = WStmt.functions_called_by_list f.body +let has_spec f = Option.is_some f.spec + +let get_by_id id f = + let stmt_list_visitor = list_visitor_builder WStmt.get_by_id id in + let aux_spec = Option.fold ~some:(WSpec.get_by_id id) ~none:`None in + let expr_getter = WExpr.get_by_id id in + let self_or_none = if f.fid = id then `WFun f else `None in + let return_getter (ret_exp : WExpr.t) = + if WExpr.get_id ret_exp = id then `Return ret_exp else `None + in + self_or_none + |>> (return_getter, f.return_expr) + |>> (expr_getter, f.return_expr) + |>> (stmt_list_visitor, f.body) + |>> (aux_spec, f.spec) + +let pp fmt f = + let pp_list_stmt = WStmt.pp_list in + match f.spec with + | None -> + Format.fprintf fmt + "@[@[function %s(%a)@] {@,%a;@,@[return@ %a@]@]@\n}" + f.name + (WPrettyUtils.pp_list Format.pp_print_string) + f.params pp_list_stmt f.body WExpr.pp f.return_expr + | Some spec -> + Format.fprintf fmt + "@[{ %a }@]@[@[function %s(%a)@] {@,\ + %a;@,\ + @[return@ %a@]@]@\n\ + }@\n\ + @[{ %a }@]" WLAssert.pp (WSpec.get_pre spec) f.name + (WPrettyUtils.pp_list Format.pp_print_string) + f.params pp_list_stmt f.body WExpr.pp f.return_expr WLAssert.pp + (WSpec.get_post spec) diff --git a/wislfp/lib/syntax/WFun.mli b/wislfp/lib/syntax/WFun.mli new file mode 100644 index 000000000..18d1340eb --- /dev/null +++ b/wislfp/lib/syntax/WFun.mli @@ -0,0 +1,43 @@ +type t = { + name : string; + params : string list; + body : WStmt.t list; + spec : WSpec.t option; + return_expr : WExpr.t; + floc : CodeLoc.t; + fid : int; + is_loop_body : bool; +} + +val get_id : t -> int +val get_loc : t -> CodeLoc.t +val get_name : t -> string +val get_spec : t -> WSpec.t option + +val add_spec : + ?existentials:string * string list -> + t -> + WLAssert.t -> + WLAssert.t -> + WLExpr.t option -> + CodeLoc.t -> + t + +val functions_called : t -> string list +val has_spec : t -> bool + +val get_by_id : + int -> + t -> + [> `None + | `Return of WExpr.t + | `WExpr of WExpr.t + | `WFun of t + | `WLAssert of WLAssert.t + | `WLCmd of WLCmd.t + | `WLExpr of WLExpr.t + | `WLFormula of WLFormula.t + | `WSpec of WSpec.t + | `WStmt of WStmt.t ] + +val pp : Format.formatter -> t -> unit diff --git a/wislfp/lib/syntax/WLAssert.ml b/wislfp/lib/syntax/WLAssert.ml new file mode 100644 index 000000000..ba80f8306 --- /dev/null +++ b/wislfp/lib/syntax/WLAssert.ml @@ -0,0 +1,118 @@ +open VisitorUtils +module SS = Set.Make (String) + +type tt = + | LEmp + | LStar of t * t + | LPred of string * WLExpr.t list + | LPointsTo of WLExpr.t * (WLExpr.t option * WLExpr.t) list + | LBlockPointsTo of WLExpr.t * (WLExpr.t option * WLExpr.t) list + | LPure of WLFormula.t + +and t = { wlaid : int; wlaloc : CodeLoc.t; wlanode : tt } + +let get la = la.wlanode +let get_id la = la.wlaid +let get_loc la = la.wlaloc + +let make bare_assert loc = + { wlanode = bare_assert; wlaloc = loc; wlaid = Generators.gen_id () } + +let copy la = make (get la) (get_loc la) + +let rec get_vars_and_lvars asrt = + let double_union (sa1, sb1) (sa2, sb2) = + (SS.union sa1 sa2, SS.union sb1 sb2) + in + let from_wlexpr_list lel = + List.fold_left double_union (SS.empty, SS.empty) + (List.map WLExpr.get_vars_and_lvars lel) + in + let from_wlexpr_option_list lel = + let lel = List.map Option.get @@ List.filter Option.is_some lel in + List.fold_left double_union (SS.empty, SS.empty) + (List.map WLExpr.get_vars_and_lvars lel) + in + + let resolve_points_to el lel = + let lel1 = List.map fst lel in + let lel2 = List.map snd lel in + let aux = + double_union (WLExpr.get_vars_and_lvars el) (from_wlexpr_list lel2) + in + double_union aux (from_wlexpr_option_list lel1) + in + + match get asrt with + | LEmp -> (SS.empty, SS.empty) + | LStar (a1, a2) -> + double_union (get_vars_and_lvars a1) (get_vars_and_lvars a2) + | LPred (_, lel) -> from_wlexpr_list lel + | LPointsTo (el, lel) -> resolve_points_to el lel + | LBlockPointsTo (el, lel) -> resolve_points_to el lel + | LPure lf -> WLFormula.get_vars_and_lvars lf + +let rec get_by_id id la = + let getter = get_by_id id in + let lexpr_getter = WLExpr.get_by_id id in + let lexpr_list_visitor = list_visitor_builder WLExpr.get_by_id id in + let lform_getter = WLFormula.get_by_id id in + let resolve_points_to le1 lle2 = + let lle1 = List.map fst lle2 in + let lle2 = List.map snd lle2 in + let lle1 = List.map Option.get @@ List.filter Option.is_some lle1 in + lexpr_getter le1 |>> (lexpr_list_visitor, lle1) + |>> (lexpr_list_visitor, lle2) + in + let aux lap = + match get lap with + | LStar (la1, la2) -> getter la1 |>> (getter, la2) + | LPred (_, lel) -> lexpr_list_visitor lel + | LPointsTo (le1, lle2) -> resolve_points_to le1 lle2 + | LBlockPointsTo (le1, lle2) -> resolve_points_to le1 lle2 + | LPure lf -> lform_getter lf + | _ -> `None + in + let self_or_none = if get_id la = id then `WLAssert la else `None in + self_or_none |>> (aux, la) + +let rec pp fmt asser = + let pair_pp fmt (perm, expr) = + match perm with + | None -> WLExpr.pp fmt expr + | Some perm -> + Format.fprintf fmt "@[(%a: %a)]@" WLExpr.pp perm WLExpr.pp expr + in + let pp_params = WPrettyUtils.pp_list WLExpr.pp in + let pp_values_with_perm = WPrettyUtils.pp_list pair_pp in + match get asser with + | LEmp -> Format.pp_print_string fmt "emp" + | LStar (a1, a2) -> Format.fprintf fmt "@[(%a) * (%a)@]" pp a1 pp a2 + | LPred (pname, lel) -> Format.fprintf fmt "@[%s(%a)@]" pname pp_params lel + | LPointsTo (le1, le2) -> + Format.fprintf fmt "@[(%a) -> %a@]" WLExpr.pp le1 pp_values_with_perm le2 + | LBlockPointsTo (le1, le2) -> + Format.fprintf fmt "@[(%a) -b-> %a@]" WLExpr.pp le1 pp_values_with_perm + le2 + | LPure f -> Format.fprintf fmt "@[%a@]" WLFormula.pp f + +let str = Format.asprintf "%a" pp + +let rec substitution (subst : (string, WLExpr.tt) Hashtbl.t) (a : t) : t = + let { wlaid; wlaloc; wlanode } = a in + let f = substitution subst in + let fe = WLExpr.substitution subst in + let f_pair (perm, expr) = + let perm = Option.map fe perm in + (perm, fe expr) + in + let wlanode = + match wlanode with + | LEmp -> LEmp + | LStar (a1, a2) -> LStar (f a1, f a2) + | LPred (name, le) -> LPred (name, List.map fe le) + | LPointsTo (e1, le) -> LPointsTo (fe e1, List.map f_pair le) + | LBlockPointsTo (e1, le) -> LBlockPointsTo (fe e1, List.map f_pair le) + | LPure frm -> LPure (WLFormula.substitution subst frm) + in + { wlaid; wlaloc; wlanode } diff --git a/wislfp/lib/syntax/WLAssert.mli b/wislfp/lib/syntax/WLAssert.mli new file mode 100644 index 000000000..4808aba81 --- /dev/null +++ b/wislfp/lib/syntax/WLAssert.mli @@ -0,0 +1,26 @@ +type tt = + | LEmp + | LStar of t * t + | LPred of string * WLExpr.t list + | LPointsTo of WLExpr.t * (WLExpr.t option * WLExpr.t) list + (** x -> a, b <=> (x -> a) * (x+1 -> b) *) + | LBlockPointsTo of WLExpr.t * (WLExpr.t option * WLExpr.t) list + | LPure of WLFormula.t + +and t + +val get : t -> tt +val get_id : t -> int +val get_loc : t -> CodeLoc.t +val make : tt -> CodeLoc.t -> t +val copy : t -> t +val get_vars_and_lvars : t -> Set.Make(String).t * Set.Make(String).t + +val get_by_id : + int -> + t -> + [> `None | `WLExpr of WLExpr.t | `WLFormula of WLFormula.t | `WLAssert of t ] + +val pp : Format.formatter -> t -> unit +val str : t -> string +val substitution : (string, WLExpr.tt) Hashtbl.t -> t -> t diff --git a/wislfp/lib/syntax/WLCmd.ml b/wislfp/lib/syntax/WLCmd.ml new file mode 100644 index 000000000..a1ab55017 --- /dev/null +++ b/wislfp/lib/syntax/WLCmd.ml @@ -0,0 +1,88 @@ +open VisitorUtils + +type tt = + | Fold of string * WLExpr.t list + | Unfold of string * WLExpr.t list + | ApplyLem of string * WLExpr.t list * string list + | LogicIf of WLExpr.t * t list * t list + | Assert of WLAssert.t * string list + | Invariant of WLAssert.t * string list * WLExpr.t option + +and t = { wlcnode : tt; wlcid : int; wlcloc : CodeLoc.t } + +let get lcmd = lcmd.wlcnode +let get_id lcmd = lcmd.wlcid +let get_loc lcmd = lcmd.wlcloc + +let make bare_lcmd loc = + { wlcnode = bare_lcmd; wlcloc = loc; wlcid = Generators.gen_id () } + +let is_inv lcmd = + match get lcmd with + | Invariant _ -> true + | _ -> false + +let is_fold lcmd = + match get lcmd with + | Fold _ -> true + | _ -> false + +let is_unfold lcmd = + match get lcmd with + | Unfold _ -> true + | _ -> false + +let rec get_by_id id lcmd = + let lexpr_getter = WLExpr.get_by_id id in + let lexpr_list_visitor = list_visitor_builder WLExpr.get_by_id id in + let list_visitor = list_visitor_builder get_by_id id in + let lassert_getter = WLAssert.get_by_id id in + let aux lcmdp = + match get lcmdp with + | Fold (_, lel) | Unfold (_, lel) | ApplyLem (_, lel, _) -> + lexpr_list_visitor lel + | LogicIf (le, lcmdl1, lcmdl2) -> + lexpr_getter le |>> (list_visitor, lcmdl1) |>> (list_visitor, lcmdl2) + | Assert (la, _) | Invariant (la, _, _) -> lassert_getter la + in + let self_or_none = if get_id lcmd = id then `WLCmd lcmd else `None in + self_or_none |>> (aux, lcmd) + +(* TODO: write pretty_print function *) +let pp fmt lcmd = + let fprintf = Format.fprintf fmt in + match get lcmd with + | Fold (pname, wlel) -> + fprintf "fold %s(%a)" pname (WPrettyUtils.pp_list WLExpr.pp) wlel + | Unfold (pname, wlel) -> + fprintf "unfold %s(%a)" pname (WPrettyUtils.pp_list WLExpr.pp) wlel + | ApplyLem (lname, wlel, _) -> + fprintf "apply %s(%a)" lname (WPrettyUtils.pp_list WLExpr.pp) wlel + (* | Assert (a, b) -> fprintf "%a" WLAssert.pp a + | Invariant (a, b) -> + let existentials = match b with + |[] -> "" + | _ -> Format.asprintf "{exists: %a}" (WPrettyUtils.pp_list Format.pp_print_string) b + in + fprintf "invariant %s %a" existentials WLAssert.pp a *) + | _ -> Format.fprintf fmt "[LOGIC COMMAND]" + +let str = Format.asprintf "%a" pp + +let rec substitution subst { wlcnode; wlcid; wlcloc } = + let f = substitution subst in + let fa = WLAssert.substitution subst in + let fe = WLExpr.substitution subst in + let wlcnode = + match wlcnode with + | Fold (pname, les) -> Fold (pname, List.map fe les) + | Unfold (pname, les) -> Unfold (pname, List.map fe les) + | ApplyLem (lname, les, binders) -> + ApplyLem (lname, List.map fe les, binders) + | LogicIf (le, cmds_t, cmds_e) -> + LogicIf (fe le, List.map f cmds_t, List.map f cmds_e) + | Assert (la, binders) -> Assert (fa la, binders) + | Invariant (la, binders, variant) -> + Invariant (fa la, binders, Option.map fe variant) + in + { wlcnode; wlcid; wlcloc } diff --git a/wislfp/lib/syntax/WLCmd.mli b/wislfp/lib/syntax/WLCmd.mli new file mode 100644 index 000000000..a3175e9eb --- /dev/null +++ b/wislfp/lib/syntax/WLCmd.mli @@ -0,0 +1,32 @@ +type tt = + | Fold of string * WLExpr.t list + | Unfold of string * WLExpr.t list + | ApplyLem of string * WLExpr.t list * string list + (** apply \{exists: ...\} ... *) + | LogicIf of WLExpr.t * t list * t list + | Assert of WLAssert.t * string list (** assert \{exists: ...\} ... *) + | Invariant of WLAssert.t * string list * WLExpr.t option + (** invariant \{exists: ... \} ...*) + +and t + +val get : t -> tt +val get_id : t -> int +val get_loc : t -> CodeLoc.t +val make : tt -> CodeLoc.t -> t +val is_inv : t -> bool +val is_fold : t -> bool +val is_unfold : t -> bool + +val get_by_id : + int -> + t -> + [> `None + | `WLExpr of WLExpr.t + | `WLFormula of WLFormula.t + | `WLAssert of WLAssert.t + | `WLCmd of t ] + +val pp : Format.formatter -> t -> unit +val str : t -> string +val substitution : (string, WLExpr.tt) Hashtbl.t -> t -> t diff --git a/wislfp/lib/syntax/WLExpr.ml b/wislfp/lib/syntax/WLExpr.ml new file mode 100644 index 000000000..db26f314f --- /dev/null +++ b/wislfp/lib/syntax/WLExpr.ml @@ -0,0 +1,91 @@ +open VisitorUtils + +type tt = + | LVal of WVal.t + | LVar of string + | PVar of string + | LBinOp of t * WBinOp.t * t + | LUnOp of WUnOp.t * t + | LLSub of t * t * t + | LEList of t list + | LESet of t list + +and t = { wleid : int; wleloc : CodeLoc.t; wlenode : tt } + +let get le = le.wlenode +let get_loc le = le.wleloc +let get_id le = le.wleid + +let make bare_lexpr loc = + { wlenode = bare_lexpr; wleloc = loc; wleid = Generators.gen_id () } + +let rec from_expr expr = + let wleid = Generators.gen_id () in + let wleloc = WExpr.get_loc expr in + let wlenode = + match WExpr.get expr with + | Val v -> LVal v + | Var x -> LVar x + | BinOp (e1, b, e2) -> LBinOp (from_expr e1, b, from_expr e2) + | UnOp (u, e) -> LUnOp (u, from_expr e) + | List el -> LEList (List.map from_expr el) + in + { wleid; wleloc; wlenode } + +let get_vars_and_lvars le = + let module SS = Set.Make (String) in + match get le with + | LVar v -> (SS.empty, SS.singleton v) + | PVar v -> (SS.singleton v, SS.empty) + | _ -> (SS.empty, SS.empty) + +let rec get_by_id id lexpr = + let getter = get_by_id id in + let list_visitor = list_visitor_builder get_by_id id in + let aux le = + match get le with + | LBinOp (le1, _, le2) -> getter le1 |>> (getter, le2) + | LUnOp (_, lep) -> getter lep + | LEList lel -> list_visitor lel + | LESet lel -> list_visitor lel + | _ -> `None + in + let self_or_none = if get_id lexpr = id then `WLExpr lexpr else `None in + self_or_none |>> (aux, lexpr) + +let rec pp fmt lexpr = + match get lexpr with + | LVal v -> WVal.pp fmt v + | LVar lx -> Format.fprintf fmt "@[%s@]" lx + | PVar x -> Format.fprintf fmt "@[%s@]" x + | LBinOp (le1, b, le2) -> + Format.fprintf fmt "@[(%a %a %a)@]" pp le1 WBinOp.pp b pp le2 + | LUnOp (u, le) -> Format.fprintf fmt "@[(%a %a)@]" WUnOp.pp u pp le + | LLSub (le1, le2, le3) -> + Format.fprintf fmt "@[sub(%a, %a, %a)@]" pp le1 pp le2 pp le3 + | LEList lel -> + WPrettyUtils.pp_list ~pre:(format_of_string "@[[") + ~suf:(format_of_string "]@]") + ~empty:(format_of_string "@[nil@]") + pp fmt lel + | LESet lel -> + WPrettyUtils.pp_list ~pre:(format_of_string "@[-{") + ~suf:(format_of_string "}-@]") pp fmt lel + +let str = Format.asprintf "%a" pp + +let rec substitution (subst : (string, tt) Hashtbl.t) (e : t) : t = + let { wleid; wleloc; wlenode } = e in + let f = substitution subst in + let wlenode = + match wlenode with + | LVal _ -> wlenode + | LVar x -> Option.value ~default:(LVar x) (Hashtbl.find_opt subst x) + | PVar x -> Option.value ~default:(PVar x) (Hashtbl.find_opt subst x) + | LBinOp (e1, binop, e2) -> LBinOp (f e1, binop, f e2) + | LUnOp (unop, e1) -> LUnOp (unop, f e1) + | LLSub (e1, e2, e3) -> LLSub (f e1, f e2, f e3) + | LEList le -> LEList (List.map f le) + | LESet le -> LESet (List.map f le) + in + { wleid; wleloc; wlenode } diff --git a/wislfp/lib/syntax/WLExpr.mli b/wislfp/lib/syntax/WLExpr.mli new file mode 100644 index 000000000..dcd6cd828 --- /dev/null +++ b/wislfp/lib/syntax/WLExpr.mli @@ -0,0 +1,22 @@ +type tt = + | LVal of WVal.t + | LVar of string + | PVar of string + | LBinOp of t * WBinOp.t * t + | LUnOp of WUnOp.t * t + | LLSub of t * t * t + | LEList of t list + | LESet of t list + +and t + +val get : t -> tt +val get_loc : t -> CodeLoc.t +val get_id : t -> int +val make : tt -> CodeLoc.t -> t +val from_expr : WExpr.t -> t +val get_vars_and_lvars : t -> Set.Make(String).t * Set.Make(String).t +val get_by_id : int -> t -> [> `None | `WLExpr of t ] +val pp : Format.formatter -> t -> unit +val str : t -> string +val substitution : (string, tt) Hashtbl.t -> t -> t diff --git a/wislfp/lib/syntax/WLFormula.ml b/wislfp/lib/syntax/WLFormula.ml new file mode 100644 index 000000000..ed01a3f86 --- /dev/null +++ b/wislfp/lib/syntax/WLFormula.ml @@ -0,0 +1,165 @@ +open VisitorUtils + +type tt = + | LTrue + | LFalse + | LNot of t + | LAnd of t * t + | LOr of t * t + | LEq of WLExpr.t * WLExpr.t + | LLess of WLExpr.t * WLExpr.t + | FLLess of WLExpr.t * WLExpr.t + | LGreater of WLExpr.t * WLExpr.t + | FLGreater of WLExpr.t * WLExpr.t + | LLessEq of WLExpr.t * WLExpr.t + | FLLessEq of WLExpr.t * WLExpr.t + | LGreaterEq of WLExpr.t * WLExpr.t + | FLGreaterEq of WLExpr.t * WLExpr.t + +and t = { wlfid : int; wlfloc : CodeLoc.t; wlfnode : tt } + +let get lf = lf.wlfnode +let get_loc e = e.wlfloc +let get_id e = e.wlfid + +let make bare_form loc = + { wlfid = Generators.gen_id (); wlfloc = loc; wlfnode = bare_form } + +let rec not f = + let make fp = make fp (get_loc f) in + match get f with + | LTrue -> make LFalse + | LFalse -> make LTrue + | LNot fp -> fp + | LAnd (f1, f2) -> make (LOr (not f1, not f2)) + | LOr (f1, f2) -> make (LAnd (not f1, not f2)) + | LLess (e1, e2) -> make (LGreaterEq (e1, e2)) + | FLLess (e1, e2) -> make (FLGreaterEq (e1, e2)) + | LLessEq (e1, e2) -> make (LGreater (e1, e2)) + | FLLessEq (e1, e2) -> make (FLGreater (e1, e2)) + | LGreater (e1, e2) -> make (LLessEq (e1, e2)) + | FLGreater (e1, e2) -> make (FLLessEq (e1, e2)) + | LGreaterEq (e1, e2) -> make (LLess (e1, e2)) + | FLGreaterEq (e1, e2) -> make (FLLess (e1, e2)) + | LEq _ -> make (LNot f) + +let rec lexpr_is_true ?(codeloc = CodeLoc.dummy) lexpr = + let f = lexpr_is_true ~codeloc in + let bare = + match WLExpr.get lexpr with + | LVal (Bool true) -> LTrue + | LVal _ -> LFalse + | LBinOp (e1, EQUAL, e2) -> LEq (e1, e2) + | LBinOp (e1, NEQ, e2) -> + let inner = make (LEq (e1, e2)) codeloc in + LNot inner + | LBinOp (e1, AND, e2) -> LAnd (f e1, f e2) + | LBinOp (e1, OR, e2) -> LOr (f e1, f e2) + | LBinOp (e1, LESSTHAN, e2) -> LLess (e1, e2) + | LBinOp (e1, FLESSTHAN, e2) -> FLLess (e1, e2) + | LBinOp (e1, LESSEQUAL, e2) -> LLessEq (e1, e2) + | LBinOp (e1, FLESSEQUAL, e2) -> FLLessEq (e1, e2) + | LBinOp (e1, GREATERTHAN, e2) -> LGreater (e1, e2) + | LBinOp (e1, FGREATERTHAN, e2) -> FLGreater (e1, e2) + | LBinOp (e1, GREATEREQUAL, e2) -> LGreaterEq (e1, e2) + | LBinOp (e1, FGREATEREQUAL, e2) -> FLGreaterEq (e1, e2) + | LUnOp (NOT, e) -> LNot (f e) + | PVar _ -> + let ttrue = WLExpr.make (LVal (Bool true)) codeloc in + LEq (lexpr, ttrue) + | _ -> LFalse + in + make bare codeloc + +let rec get_vars_and_lvars f = + let module SS = Set.Make (String) in + let double_union (sa1, sb1) (sa2, sb2) = + (SS.union sa1 sa2, SS.union sb1 sb2) + in + match get f with + | LNot f -> get_vars_and_lvars f + | LAnd (f1, f2) | LOr (f1, f2) -> + double_union (get_vars_and_lvars f1) (get_vars_and_lvars f2) + | LEq (e1, e2) + | LLess (e1, e2) + | FLLess (e1, e2) + | LGreater (e1, e2) + | FLGreater (e1, e2) + | LLessEq (e1, e2) + | FLLessEq (e1, e2) + | LGreaterEq (e1, e2) + | FLGreaterEq (e1, e2) -> + double_union (WLExpr.get_vars_and_lvars e1) (WLExpr.get_vars_and_lvars e2) + | _ -> (SS.empty, SS.empty) + +let rec get_by_id id lf = + let getter = get_by_id id in + let lexpr_getter = WLExpr.get_by_id id in + let aux lfp = + match get lfp with + | LNot lfpp -> getter lfpp + | LAnd (lf1, lf2) | LOr (lf1, lf2) -> getter lf1 |>> (getter, lf2) + | LEq (le1, le2) + | LLess (le1, le2) + | FLLess (le1, le2) + | LGreater (le1, le2) + | FLGreater (le1, le2) + | LLessEq (le1, le2) + | FLLessEq (le1, le2) + | LGreaterEq (le1, le2) + | FLGreaterEq (le1, le2) -> lexpr_getter le1 |>> (lexpr_getter, le2) + | _ -> `None + in + let self_or_none = if get_id lf = id then `WLFormula lf else `None in + self_or_none |>> (aux, lf) + +let rec pp fmt formula = + match get formula with + | LTrue -> Format.pp_print_string fmt "True" + | LFalse -> Format.pp_print_string fmt "False" + | LNot f -> Format.fprintf fmt "@[!(%a)@]" pp f + | LAnd (f1, f2) -> Format.fprintf fmt "@[(%a) /\\ (%a)@]" pp f1 pp f2 + | LOr (f1, f2) -> Format.fprintf fmt "@[(%a) \\/ (%a)@]" pp f1 pp f2 + | LEq (le1, le2) -> + Format.fprintf fmt "@[(%a) == (%a)@]" WLExpr.pp le1 WLExpr.pp le2 + | LLess (le1, le2) -> + Format.fprintf fmt "@[(%a) <# (%a)@]" WLExpr.pp le1 WLExpr.pp le2 + | FLLess (le1, le2) -> + Format.fprintf fmt "@[(%a) f<# (%a)@]" WLExpr.pp le1 WLExpr.pp le2 + | LGreater (le1, le2) -> + Format.fprintf fmt "@[(%a) ># (%a)@]" WLExpr.pp le1 WLExpr.pp le2 + | FLGreater (le1, le2) -> + Format.fprintf fmt "@[(%a) f># (%a)@]" WLExpr.pp le1 WLExpr.pp le2 + | LLessEq (le1, le2) -> + Format.fprintf fmt "@[(%a) <=# (%a)@]" WLExpr.pp le1 WLExpr.pp le2 + | FLLessEq (le1, le2) -> + Format.fprintf fmt "@[(%a) f<=# (%a)@]" WLExpr.pp le1 WLExpr.pp le2 + | LGreaterEq (le1, le2) -> + Format.fprintf fmt "@[(%a) >=# (%a)@]" WLExpr.pp le1 WLExpr.pp le2 + | FLGreaterEq (le1, le2) -> + Format.fprintf fmt "@[(%a) f>=# (%a)@]" WLExpr.pp le1 WLExpr.pp le2 + +let str = Format.asprintf "%a" pp + +let rec substitution (subst : (string, WLExpr.tt) Hashtbl.t) (frm : t) : t = + let { wlfid; wlfloc; wlfnode } = frm in + let f = substitution subst in + let fe = WLExpr.substitution subst in + let wlfnode = + match wlfnode with + | LTrue -> LTrue + | LFalse -> LFalse + | LNot frm -> LNot (f frm) + | LAnd (frm1, frm2) -> LAnd (f frm1, f frm2) + | LOr (frm1, frm2) -> LOr (f frm1, f frm2) + | LEq (e1, e2) -> LEq (fe e1, fe e2) + | LLess (e1, e2) -> LLess (fe e1, fe e2) + | FLLess (e1, e2) -> FLLess (fe e1, fe e2) + | LGreater (e1, e2) -> LGreater (fe e1, fe e2) + | FLGreater (e1, e2) -> FLGreater (fe e1, fe e2) + | LLessEq (e1, e2) -> LLessEq (fe e1, fe e2) + | FLLessEq (e1, e2) -> FLLessEq (fe e1, fe e2) + | LGreaterEq (e1, e2) -> LGreaterEq (fe e1, fe e2) + | FLGreaterEq (e1, e2) -> FLGreaterEq (fe e1, fe e2) + in + { wlfid; wlfloc; wlfnode } diff --git a/wislfp/lib/syntax/WLFormula.mli b/wislfp/lib/syntax/WLFormula.mli new file mode 100644 index 000000000..fab3f250f --- /dev/null +++ b/wislfp/lib/syntax/WLFormula.mli @@ -0,0 +1,29 @@ +type tt = + | LTrue + | LFalse + | LNot of t + | LAnd of t * t + | LOr of t * t + | LEq of WLExpr.t * WLExpr.t + | LLess of WLExpr.t * WLExpr.t + | FLLess of WLExpr.t * WLExpr.t + | LGreater of WLExpr.t * WLExpr.t + | FLGreater of WLExpr.t * WLExpr.t + | LLessEq of WLExpr.t * WLExpr.t + | FLLessEq of WLExpr.t * WLExpr.t + | LGreaterEq of WLExpr.t * WLExpr.t + | FLGreaterEq of WLExpr.t * WLExpr.t + +and t + +val get : t -> tt +val get_loc : t -> CodeLoc.t +val get_id : t -> int +val make : tt -> CodeLoc.t -> t +val lexpr_is_true : ?codeloc:PwUtils.CodeLoc.t -> WLExpr.t -> t +val not : t -> t +val get_vars_and_lvars : t -> Set.Make(String).t * Set.Make(String).t +val get_by_id : int -> t -> [> `None | `WLExpr of WLExpr.t | `WLFormula of t ] +val pp : Format.formatter -> t -> unit +val str : t -> string +val substitution : (string, WLExpr.tt) Hashtbl.t -> t -> t diff --git a/wislfp/lib/syntax/WLemma.ml b/wislfp/lib/syntax/WLemma.ml new file mode 100644 index 000000000..8c13e664b --- /dev/null +++ b/wislfp/lib/syntax/WLemma.ml @@ -0,0 +1,32 @@ +open VisitorUtils + +type t = { + lemma_name : string; + lemma_params : string list; + lemma_proof : WLCmd.t list option; + lemma_variant : WLExpr.t option; + lemma_hypothesis : WLAssert.t; + lemma_conclusion : WLAssert.t; + lemma_id : int; + lemma_loc : CodeLoc.t; +} + +let get_id l = l.lemma_id +let get_loc l = l.lemma_loc + +let get_by_id id lemma = + let lcmd_list_visitor = list_visitor_builder WLCmd.get_by_id id in + let lexpr_getter = WLExpr.get_by_id id in + let aux_proof = Option.fold ~some:lcmd_list_visitor ~none:`None in + let aux_variant = Option.fold ~some:lexpr_getter ~none:`None in + let assert_getter = WLAssert.get_by_id id in + let self_or_none = if get_id lemma = id then `WLemma lemma else `None in + self_or_none + |>> (assert_getter, lemma.lemma_hypothesis) + |>> (assert_getter, lemma.lemma_conclusion) + |>> (aux_proof, lemma.lemma_proof) + |>> (aux_variant, lemma.lemma_variant) + +(* TODO: write pretty_print function *) + +(* let str = Format.asprintf "%a" pp *) diff --git a/wislfp/lib/syntax/WLemma.mli b/wislfp/lib/syntax/WLemma.mli new file mode 100644 index 000000000..955957af4 --- /dev/null +++ b/wislfp/lib/syntax/WLemma.mli @@ -0,0 +1,24 @@ +type t = { + lemma_name : string; + lemma_params : string list; + lemma_proof : WLCmd.t list option; + lemma_variant : WLExpr.t option; + lemma_hypothesis : WLAssert.t; + lemma_conclusion : WLAssert.t; + lemma_id : int; + lemma_loc : CodeLoc.t; +} + +val get_id : t -> int +val get_loc : t -> CodeLoc.t + +val get_by_id : + int -> + t -> + [> `None + | `WExpr of WExpr.t + | `WLAssert of WLAssert.t + | `WLCmd of WLCmd.t + | `WLExpr of WLExpr.t + | `WLFormula of WLFormula.t + | `WLemma of t ] diff --git a/wislfp/lib/syntax/WPred.ml b/wislfp/lib/syntax/WPred.ml new file mode 100644 index 000000000..53d90c9ae --- /dev/null +++ b/wislfp/lib/syntax/WPred.ml @@ -0,0 +1,25 @@ +open VisitorUtils + +type t = { + pred_name : string; + pred_params : (string * WType.t option) list; + pred_definitions : WLAssert.t list; + pred_ins : int list; + pred_nounfold : bool; + pred_loc : CodeLoc.t; + pred_id : int; +} + +let get_id p = p.pred_id +let get_loc p = p.pred_loc +let get_name p = p.pred_name +let get_ins p = p.pred_ins + +let get_by_id id pred = + let lassert_list_visitor = list_visitor_builder WLAssert.get_by_id id in + let self_or_none = if get_id pred = id then `WPred pred else `None in + self_or_none |>> (lassert_list_visitor, pred.pred_definitions) + +(* TODO: write pretty_print function *) + +(* let str = Format.asprintf "%a" pp *) diff --git a/wislfp/lib/syntax/WPred.mli b/wislfp/lib/syntax/WPred.mli new file mode 100644 index 000000000..bacd3b7d5 --- /dev/null +++ b/wislfp/lib/syntax/WPred.mli @@ -0,0 +1,23 @@ +type t = { + pred_name : string; + pred_params : (string * WType.t option) list; + pred_definitions : WLAssert.t list; + pred_ins : int list; + pred_nounfold : bool; + pred_loc : CodeLoc.t; + pred_id : int; +} + +val get_id : t -> int +val get_loc : t -> CodeLoc.t +val get_name : t -> string +val get_ins : t -> int list + +val get_by_id : + int -> + t -> + [> `None + | `WLAssert of WLAssert.t + | `WLExpr of WLExpr.t + | `WLFormula of WLFormula.t + | `WPred of t ] diff --git a/wislfp/lib/syntax/WProg.ml b/wislfp/lib/syntax/WProg.ml new file mode 100644 index 000000000..461e5d53a --- /dev/null +++ b/wislfp/lib/syntax/WProg.ml @@ -0,0 +1,94 @@ +open VisitorUtils + +type t = { + context : WFun.t list; + predicates : WPred.t list; + lemmas : WLemma.t list; +} + +let get_context p = p.context + +let pp_context = + WPrettyUtils.pp_list ~sep:(format_of_string "@,@,") + ~suf:(format_of_string "@]@.") WFun.pp + +let pp fmt = function + | prog -> Format.fprintf fmt "%a" pp_context prog.context + +module StringSet = Set.Make (String) +module StringMap = Map.Make (String) + +let never_called_during_symb prog = + let fmap = + List.fold_left + (fun map f -> StringMap.add (WFun.get_name f) f map) + StringMap.empty prog.context + in + let allf = StringSet.of_list (List.map WFun.get_name prog.context) in + let has_spec fname = + let f = StringMap.find fname fmap in + WFun.has_spec f + in + let have_spec = StringSet.filter has_spec allf in + let rec find_fixed_point compare f a = + let b = f a in + if compare a b = 0 then b else find_fixed_point compare f b + in + let fold_fun fname set = + let f = StringMap.find_opt fname fmap in + StringSet.union set + (StringSet.of_list (Option.fold ~some:WFun.functions_called ~none:[] f)) + in + let step set = StringSet.fold fold_fun set set in + let called = find_fixed_point StringSet.compare step have_spec in + let not_called_names = StringSet.diff allf called in + let not_called = + List.map + (fun x -> StringMap.find x fmap) + (StringSet.elements not_called_names) + in + not_called + +let get_pred prog name = + let rec aux = function + | [] -> None + | p :: r -> if String.equal (WPred.get_name p) name then Some p else aux r + in + aux prog.predicates + +let get_fun prog name = + let rec aux = function + | [] -> None + | p :: r -> if String.equal (WFun.get_name p) name then Some p else aux r + in + aux prog.context + +let get_by_id ?(fname = None) prog id = + match id with + | None -> `None + | Some id -> ( + let aux_f = list_visitor_builder WFun.get_by_id id in + let aux_p = list_visitor_builder WPred.get_by_id id in + let aux_l = list_visitor_builder WLemma.get_by_id id in + let fun_getter = WFun.get_by_id id in + match fname with + | None -> + aux_f prog.context |>> (aux_p, prog.predicates) + |>> (aux_l, prog.lemmas) + | Some f -> ( + match List.find_opt (fun ff -> ff.WFun.name = f) prog.context with + | None -> `None + | Some ff -> fun_getter ff)) + +let get_function_name_of_element prog id = + let is_in_function f = + match WFun.get_by_id id f with + | `None -> false + | _ -> true + in + let rec find_f l = + match l with + | f :: r -> if is_in_function f then WFun.get_name f else find_f r + | _ -> "" + in + find_f prog.context diff --git a/wislfp/lib/syntax/WProg.mli b/wislfp/lib/syntax/WProg.mli new file mode 100644 index 000000000..941489a06 --- /dev/null +++ b/wislfp/lib/syntax/WProg.mli @@ -0,0 +1,31 @@ +type t = { + context : WFun.t list; + predicates : WPred.t list; + lemmas : WLemma.t list; +} + +val get_context : t -> WFun.t list + +val get_by_id : + ?fname:string option -> + t -> + int option -> + [> `None + | `Return of WExpr.t + | `WExpr of WExpr.t + | `WFun of WFun.t + | `WLAssert of WLAssert.t + | `WLCmd of WLCmd.t + | `WLExpr of WLExpr.t + | `WLFormula of WLFormula.t + | `WLemma of WLemma.t + | `WPred of WPred.t + | `WSpec of WSpec.t + | `WStmt of WStmt.t ] + +val get_pred : t -> string -> WPred.t option +val get_fun : t -> string -> WFun.t option +val never_called_during_symb : t -> WFun.t list +val pp_context : Format.formatter -> WFun.t list -> unit +val pp : Format.formatter -> t -> unit +val get_function_name_of_element : t -> int -> string diff --git a/wislfp/lib/syntax/WSpec.ml b/wislfp/lib/syntax/WSpec.ml new file mode 100644 index 000000000..71214181c --- /dev/null +++ b/wislfp/lib/syntax/WSpec.ml @@ -0,0 +1,36 @@ +open VisitorUtils + +type t = { + pre : WLAssert.t; + post : WLAssert.t; + variant : WLExpr.t option; + existentials : (string * string list) option; + spid : int; + fname : string; + (* name of the function *) + fparams : string list; + (* parameters of the function *) + sploc : CodeLoc.t; +} + +let get_id spec = spec.spid +let get_pre spec = spec.pre +let get_post spec = spec.post +let get_loc spec = spec.sploc + +let get_by_id id spec = + let lassert_getter = WLAssert.get_by_id id in + let self_or_none = if get_id spec = id then `WSpec spec else `None in + self_or_none |>> (lassert_getter, spec.pre) |>> (lassert_getter, spec.post) + +let make ?existentials pre post variant fname fparams loc = + { + pre; + post; + variant; + spid = Generators.gen_id (); + sploc = loc; + fname; + fparams; + existentials; + } diff --git a/wislfp/lib/syntax/WSpec.mli b/wislfp/lib/syntax/WSpec.mli new file mode 100644 index 000000000..4a60c441e --- /dev/null +++ b/wislfp/lib/syntax/WSpec.mli @@ -0,0 +1,35 @@ +type t = { + pre : WLAssert.t; (** Precondition *) + post : WLAssert.t; (** Postcondition *) + variant : WLExpr.t option; (** Variant *) + existentials : (string * string list) option; (** Existentials in the spec *) + spid : int; (** Unique identifier of AST el *) + fname : string; (** Name of the function the spec is attached to *) + fparams : string list; + (** Parameters of the function the spec is attached to *) + sploc : CodeLoc.t; (** Code location of the spec *) +} + +val get_id : t -> int +val get_pre : t -> WLAssert.t +val get_post : t -> WLAssert.t +val get_loc : t -> CodeLoc.t + +val get_by_id : + int -> + t -> + [> `None + | `WLAssert of WLAssert.t + | `WLExpr of WLExpr.t + | `WLFormula of WLFormula.t + | `WSpec of t ] + +val make : + ?existentials:string * string list -> + WLAssert.t -> + WLAssert.t -> + WLExpr.t option -> + string -> + string list -> + CodeLoc.t -> + t diff --git a/wislfp/lib/syntax/WStmt.ml b/wislfp/lib/syntax/WStmt.ml new file mode 100644 index 000000000..168f9a3a4 --- /dev/null +++ b/wislfp/lib/syntax/WStmt.ml @@ -0,0 +1,151 @@ +open VisitorUtils + +type tt = + | Skip + | VarAssign of string * WExpr.t + | New of string * int + | Dispose of WExpr.t + | Lookup of string * WExpr.t (* x := [e] *) + | Update of WExpr.t * WExpr.t (* [e] := [e] *) + | FunCall of + string + * string + * WExpr.t list + * (string * (string * WLExpr.t) list) option + (* The last bit is only for internal use *) + | While of WExpr.t * t list + | If of WExpr.t * t list * t list + | Par of t list + | Logic of WLCmd.t + +and t = { sid : int; sloc : CodeLoc.t; snode : tt } + +let get lcmd = lcmd.snode +let get_id lcmd = lcmd.sid +let get_loc lcmd = lcmd.sloc + +let make (bare_stmt : tt) (loc : CodeLoc.t) = + let sid = Generators.gen_id () in + { sloc = loc; sid; snode = bare_stmt } + +let rec pp_list fmt = + (WPrettyUtils.pp_list ~sep:(format_of_string ";@\n") pp) fmt + +and pp fmt stmt = + match get stmt with + | Skip -> Format.fprintf fmt "@[%s@]" "skip" + | VarAssign (v, e) -> Format.fprintf fmt "@[%s := %a@]" v WExpr.pp e + | New (v, r) -> Format.fprintf fmt "@[%s := new(%i)@]" v r + | Dispose e -> Format.fprintf fmt "@[free@ %a@]" WExpr.pp e + | Lookup (v, e) -> Format.fprintf fmt "@[%s := [%a]@]" v WExpr.pp e + | Update (e1, e2) -> + Format.fprintf fmt "@[[%a] := %a@]" WExpr.pp e1 WExpr.pp e2 + | FunCall (v, f, el, _) -> + Format.fprintf fmt "@[%s := %s(%a)@]" v f + (WPrettyUtils.pp_list WExpr.pp) + el + | While (e, s) -> + Format.fprintf fmt "@[@[while(%a) {@\n%a@]@\n}@]" WExpr.pp e pp_list + s + | If (e, s1, s2) -> + Format.fprintf fmt + "@[@[if(%a) {@\n%a@]@\n@[} else {@\n%a@]@\n}@]" WExpr.pp e + pp_list s1 pp_list s2 + | Par s -> Format.fprintf fmt "@[@[par {@\n%a@]@\n}@]" pp_list s + | Logic lcmd -> Format.fprintf fmt "@[[[ %a ]]@]" WLCmd.pp lcmd + +and pp_head fmt stmt = + match get stmt with + | If (e, _, _) -> Format.fprintf fmt "if (%a)" WExpr.pp e + | While (e, _) -> Format.fprintf fmt "while (%a)" WExpr.pp e + | _ -> pp fmt stmt + +let is_while s = + match get s with + | While _ -> true + | _ -> false + +let is_fold s = + match get s with + | Logic lcmd when WLCmd.is_fold lcmd -> true + | _ -> false + +let is_unfold s = + match get s with + | Logic lcmd when WLCmd.is_unfold lcmd -> true + | _ -> false + +let functions_called_by_list sl = + let rec aux already = function + | [] -> already + | { snode = FunCall (_, fname, _, _); _ } :: r -> aux (fname :: already) r + | { snode = While (_, slp); _ } :: r -> aux (aux already slp @ already) r + | { snode = If (_, slp1, slp2); _ } :: r -> + aux (aux already slp1 @ aux already slp2 @ already) r + | { snode = Par s; _ } :: r -> aux (aux already s @ already) r + | _l :: r -> aux already r + in + aux [] sl + +let rec get_by_id id stmt = + let expr_getter = WExpr.get_by_id id in + let expr_list_visitor = list_visitor_builder WExpr.get_by_id id in + let list_visitor = list_visitor_builder get_by_id id in + let lcmd_getter = WLCmd.get_by_id id in + let aux s = + match get s with + | Dispose e | Lookup (_, e) | VarAssign (_, e) -> expr_getter e + | Update (e1, e2) -> expr_getter e1 |>> (expr_getter, e2) + | FunCall (_, _, el, _) -> expr_list_visitor el + | While (e, sl) -> expr_getter e |>> (list_visitor, sl) + | If (e, sl1, sl2) -> + expr_getter e |>> (list_visitor, sl1) |>> (list_visitor, sl2) + | Par s -> list_visitor s + | Logic lcmd -> lcmd_getter lcmd + | New _ | Skip -> `None + in + let self_or_none = if get_id stmt = id then `WStmt stmt else `None in + self_or_none |>> (aux, stmt) + +(** This function checks that the statement list has at least one concrete statement + and that every loop is preceded by an invariant + It returns true and an empty string if it is the case, false with a message otherwise *) + +(* let check_consistency sl loc = + let message_need_concrete = "This statement bloc contains only logic commands, it needs concrete statements." in + let message_need_invariant = "This while loop needs to be preceeded by an invariant." in + let message_empty_statement = "This bloc cannot be empty, it needs at least one concrete statement." in + let lcmd_is_inv lcmd = + match (WLCmd.get lcmd) with + | WLCmd.Invariant _ -> true + | _ -> false + in + let rec aux concrete_seen has_invariant start slp = + match slp with + | [] when start -> (false, message_empty_statement, loc) + | [] when concrete_seen -> (true, "", loc) + | [] (* when not concrete_seen *) -> (false, message_need_concrete, loc) + | s::rest -> + begin + match (get s) with + | Logic lcmd -> aux concrete_seen (has_invariant || lcmd_is_inv lcmd) false rest + | While _ when not has_invariant -> + (* TODO: make that work *) + let while_loc = get_loc s in + (* let cl = WCodeLens.make_add_invariant while_loc in + let () = LSPP.new_codelens cl in *) + let warning = WError.build_warning_invariant while_loc in + let () = LSPP.new_diagnostic warning in + (* Uncomment to create error *) + (* (false, message_need_invariant, while_loc) *) + aux true false false rest + | _any_other_concrete_case -> aux true false false rest + end + in + let (is_consistent, message, eloc) = aux false false true sl in + if (not is_consistent) then ( + let () = WError.consistency_errors := true in + let werror = WError.build_consistency_error message eloc "" in + let () = LSPP.new_diagnostic werror in + LSPP.output_and_exit (fun _ _ -> ()) () (); + ) else () *) diff --git a/wislfp/lib/syntax/WStmt.mli b/wislfp/lib/syntax/WStmt.mli new file mode 100644 index 000000000..bdb42f472 --- /dev/null +++ b/wislfp/lib/syntax/WStmt.mli @@ -0,0 +1,45 @@ +type tt = + | Skip + | VarAssign of string * WExpr.t (** x := e *) + | New of string * int (** x := new(k) *) + | Dispose of WExpr.t (** free(e) *) + | Lookup of string * WExpr.t (** x := [e] *) + | Update of WExpr.t * WExpr.t (** [e] := [e] *) + | FunCall of + string + * string + * WExpr.t list + * (string * (string * WLExpr.t) list) option + (** x := f(e1, ..., en), last bit should be ignored *) + | While of WExpr.t * t list (** while (e) \{ s \} *) + | If of WExpr.t * t list * t list (** if (e) \{ s \} else \{ s \} *) + | Par of t list + | Logic of WLCmd.t (** logic command *) + +and t = { sid : int; sloc : CodeLoc.t; snode : tt } + +val get : t -> tt +val get_id : t -> int +val get_loc : t -> CodeLoc.t +val make : tt -> CodeLoc.t -> t +val pp_list : Format.formatter -> t list -> unit +val pp : Format.formatter -> t -> unit +val pp_head : Format.formatter -> t -> unit +val is_while : t -> bool +val is_fold : t -> bool +val is_unfold : t -> bool + +val get_by_id : + int -> + t -> + [> `None + | `WExpr of WExpr.t + | `WLAssert of WLAssert.t + | `WLCmd of WLCmd.t + | `WLExpr of WLExpr.t + | `WLFormula of WLFormula.t + | `WStmt of t ] + +val functions_called_by_list : t list -> string list + +(* val check_consistency : t list -> CodeLoc.t -> unit *) diff --git a/wislfp/lib/syntax/WType.ml b/wislfp/lib/syntax/WType.ml new file mode 100644 index 000000000..ed00814cd --- /dev/null +++ b/wislfp/lib/syntax/WType.ml @@ -0,0 +1,257 @@ +type t = + (* Used only for work in compilation *) + | WList + | WNull + | WBool + | WString + | WPtr + | WInt + | WFloat + | WAny + | WSet + +(** Are types t1 and t2 compatible *) +let compatible t1 t2 = + match (t1, t2) with + | WAny, _ -> true + | _, WAny -> true + | t1, t2 when t1 = t2 -> true + | _ -> false + +let strongest t1 t2 = + match (t1, t2) with + | WAny, t -> t + | t, WAny -> t + | _ -> t1 + +(* careful there is no strongest for two different types *) + +let pp fmt t = + let s = Format.fprintf fmt "@[%s@]" in + match t with + | WList -> s "List" + | WNull -> s "NullType" + | WBool -> s "Bool" + | WString -> s "String" + | WPtr -> s "Pointer" + | WInt -> s "Int" + | WFloat -> s "Float" + | WAny -> s "Any" + | WSet -> s "Set" + +exception Unmatching_types + +module TypeMap = Map.Make (struct + type t = WLExpr.tt + + let compare = Stdlib.compare +end) + +let of_variable (var : string) (type_context : t TypeMap.t) : t option = + TypeMap.find_opt (WLExpr.PVar var) type_context + +let of_val v = + let open WVal in + match v with + | Bool _ -> WBool + | Int _ -> WInt + | Float _ -> WFloat + | Str _ -> WString + | Null -> WNull + | VList _ -> WList + +(** returns (x, y) when unop takes type x and returns type y *) +let of_unop u = + match u with + | WUnOp.NOT -> (WBool, WBool) + | WUnOp.LEN -> (WList, WInt) + | WUnOp.REV -> (WList, WList) + | WUnOp.HEAD -> (WList, WAny) + | WUnOp.TAIL -> (WList, WList) + +(** returns (x, y, z) when binop takes types x and y and returns type z *) +let of_binop b = + match b with + | WBinOp.NEQ | WBinOp.EQUAL -> (WAny, WAny, WBool) + | WBinOp.LESSTHAN + | WBinOp.GREATERTHAN + | WBinOp.LESSEQUAL + | WBinOp.GREATEREQUAL -> (WInt, WInt, WBool) + | WBinOp.FLESSTHAN + | WBinOp.FGREATERTHAN + | WBinOp.FLESSEQUAL + | WBinOp.FGREATEREQUAL -> (WFloat, WFloat, WBool) + | WBinOp.TIMES | WBinOp.DIV | WBinOp.MOD -> (WInt, WInt, WInt) + | WBinOp.FTIMES | WBinOp.FDIV | WBinOp.FMOD -> (WFloat, WFloat, WFloat) + | WBinOp.AND | WBinOp.OR -> (WBool, WBool, WBool) + | WBinOp.LSTCONS -> (WAny, WList, WList) + | WBinOp.LSTCAT -> (WList, WList, WList) + | WBinOp.LSTNTH -> (WList, WInt, WAny) + | WBinOp.PLUS | WBinOp.MINUS -> (WAny, WAny, WAny) + | WBinOp.FPLUS | WBinOp.FMINUS -> (WFloat, WFloat, WFloat) + +(* TODO: improve this, because we can add Ints AND Pointers *) + +(** checks and adds to typemap *) +let needs_to_be expr t knownp = + let bare_expr = WLExpr.get expr in + match TypeMap.find_opt bare_expr knownp with + | Some tp when not (compatible t tp) -> + failwith + (Format.asprintf + "I inferred both types %a and %a on expression %a at location %s" pp + tp pp t WLExpr.pp expr + (CodeLoc.str (WLExpr.get_loc expr))) + | Some tp -> TypeMap.add bare_expr (strongest t tp) knownp + | None -> TypeMap.add bare_expr t knownp + +(** Infers a TypeMap from a logic_expr *) +let rec infer_logic_expr knownp lexpr = + let open WLExpr in + let bare_lexpr = get lexpr in + match bare_lexpr with + | LVal v -> TypeMap.add bare_lexpr (of_val v) knownp + | LBinOp (le1, b, le2) -> + let inferred = infer_logic_expr (infer_logic_expr knownp le1) le2 in + let t1, t2, t3 = of_binop b in + TypeMap.add bare_lexpr t3 + (needs_to_be le1 t1 (needs_to_be le2 t2 inferred)) + | LUnOp (u, le) -> + let inferred = infer_logic_expr knownp le in + let t1, t2 = of_unop u in + TypeMap.add bare_lexpr t2 (needs_to_be le t1 inferred) + | LLSub (le1, le2, le3) -> + let inferred = + infer_logic_expr + (infer_logic_expr (infer_logic_expr knownp le1) le2) + le3 + in + let t0, t1, t2, t3 = (WList, WList, WInt, WInt) in + TypeMap.add bare_lexpr t0 + (needs_to_be le1 t1 (needs_to_be le2 t2 (needs_to_be le3 t3 inferred))) + | LVar _ -> knownp + | PVar _ -> knownp + | LEList lel -> + TypeMap.add bare_lexpr WList (List.fold_left infer_logic_expr knownp lel) + | LESet lel -> + TypeMap.add bare_lexpr WSet (List.fold_left infer_logic_expr knownp lel) + +(** Single step of inference for that gets a TypeMap from a single assertion *) +let rec infer_single_assert_step asser known = + let same_type e1 e2 knownp = + let bare_e1, bare_e2 = (WLExpr.get e1, WLExpr.get e2) in + let topt1 = TypeMap.find_opt bare_e1 knownp in + let topt2 = TypeMap.find_opt bare_e2 knownp in + match (topt1, topt2) with + | Some t1, Some t2 when not (compatible t1 t2) -> + failwith + (Format.asprintf + "Expressions %a and %a should have the same type but are of types \ + %a and %a in assertion %a at location %s" + WLExpr.pp e1 WLExpr.pp e2 pp t1 pp t2 WLAssert.pp asser + (CodeLoc.str (WLAssert.get_loc asser))) + | Some t1, Some t2 -> Some (strongest t1 t2) + | Some t1, None -> Some t1 + | None, Some t2 -> Some t2 + | None, None -> None + in + let rec infer_formula f k = + match WLFormula.get f with + | WLFormula.LTrue | WLFormula.LFalse -> k + | WLFormula.LNot _ -> TypeMap.empty + | WLFormula.LAnd (f1, f2) | WLFormula.LOr (f1, f2) -> + infer_formula f2 (infer_formula f1 known) + | WLFormula.LEq (le1, le2) -> ( + let bare_le1, bare_le2 = (WLExpr.get le1, WLExpr.get le2) in + let inferred = infer_logic_expr (infer_logic_expr known le1) le2 in + let topt = same_type le1 le2 inferred in + match topt with + | Some t -> TypeMap.add bare_le1 t (TypeMap.add bare_le2 t inferred) + | None -> inferred) + | WLFormula.LLess (le1, le2) + | WLFormula.LGreater (le1, le2) + | WLFormula.LLessEq (le1, le2) + | WLFormula.LGreaterEq (le1, le2) -> + let bare_le1, bare_le2 = (WLExpr.get le1, WLExpr.get le2) in + let inferred = infer_logic_expr (infer_logic_expr known le1) le2 in + let inferredp = needs_to_be le1 WInt (needs_to_be le2 WInt inferred) in + TypeMap.add bare_le1 WInt (TypeMap.add bare_le2 WInt inferredp) + | WLFormula.FLLess (le1, le2) + | WLFormula.FLGreater (le1, le2) + | WLFormula.FLLessEq (le1, le2) + | WLFormula.FLGreaterEq (le1, le2) -> + let bare_le1, bare_le2 = (WLExpr.get le1, WLExpr.get le2) in + let inferred = infer_logic_expr (infer_logic_expr known le1) le2 in + let inferredp = + needs_to_be le1 WFloat (needs_to_be le2 WFloat inferred) + in + TypeMap.add bare_le1 WFloat (TypeMap.add bare_le2 WFloat inferredp) + in + match WLAssert.get asser with + | WLAssert.LEmp -> known + | WLAssert.LStar (la1, la2) -> + infer_single_assert_step la2 (infer_single_assert_step la1 known) + | WLAssert.LPred (_, lel) -> List.fold_left infer_logic_expr known lel + | WLAssert.LPointsTo (le1, le2) -> + let le_perm = + List.map Option.get @@ List.filter Option.is_some @@ List.map fst le2 + in + let le2 = List.map snd le2 in + let inferred = + List.fold_left infer_logic_expr (infer_logic_expr known le1) le2 + in + let inferred = + List.fold_left (fun acc p -> needs_to_be p WFloat acc) inferred le_perm + in + needs_to_be le1 WList inferred + | WLAssert.LBlockPointsTo (le1, le2) -> + let le_perm = + List.map Option.get @@ List.filter Option.is_some @@ List.map fst le2 + in + let le2 = List.map snd le2 in + let inferred = + List.fold_left infer_logic_expr (infer_logic_expr known le1) le2 + in + let inferred = + List.fold_left (fun acc p -> needs_to_be p WFloat acc) inferred le_perm + in + needs_to_be le1 WList inferred + | WLAssert.LPure f -> infer_formula f known + +let infer_single_assert known asser = + let rec find_fixed_point f a = + let b = f a in + if Stdlib.compare a b = 0 then b else find_fixed_point f b + in + find_fixed_point (infer_single_assert_step asser) known + +let infer_types_pred (params : (string * t option) list) assert_list = + let join_params_and_asserts _le topt1 topt2 = + match (topt1, topt2) with + | Some t1, Some t2 when t1 = t2 -> Some t1 + | Some t, None when t <> WAny -> Some t + | None, Some t when t <> WAny -> Some t + | _ -> None + in + let join_asserts _le topt1 topt2 = + match (topt1, topt2) with + | Some t1, Some t2 when t1 = t2 -> Some t1 + | _ -> None + in + let infers_on_params = + List.fold_left + (fun (map : 'a TypeMap.t) (x, ot) -> + match ot with + | None -> map + | Some t -> TypeMap.add (PVar x) t map) + TypeMap.empty params + in + let infers_on_asserts = + List.map (infer_single_assert TypeMap.empty) assert_list + in + let hd, tl = (List.hd infers_on_asserts, List.tl infers_on_asserts) in + let infers_on_asserts = List.fold_left (TypeMap.merge join_asserts) hd tl in + let result = + TypeMap.merge join_params_and_asserts infers_on_params infers_on_asserts + in + result diff --git a/wislfp/lib/syntax/WType.mli b/wislfp/lib/syntax/WType.mli new file mode 100644 index 000000000..54156a1be --- /dev/null +++ b/wislfp/lib/syntax/WType.mli @@ -0,0 +1,17 @@ +type t = WList | WNull | WBool | WString | WPtr | WInt | WFloat | WAny | WSet + +val compatible : t -> t -> bool +val strongest : t -> t -> t +val pp : Format.formatter -> t -> unit + +exception Unmatching_types + +module TypeMap : sig + type key = WLExpr.tt + type +'a t +end + +val of_variable : string -> t TypeMap.t -> t option + +val infer_types_pred : + (string * t option) list -> WLAssert.t list -> t TypeMap.t diff --git a/wislfp/lib/syntax/WUnOp.ml b/wislfp/lib/syntax/WUnOp.ml new file mode 100644 index 000000000..13db4166b --- /dev/null +++ b/wislfp/lib/syntax/WUnOp.ml @@ -0,0 +1,17 @@ +type t = NOT | LEN | REV | HEAD | TAIL + +let is_logic_only u = + match u with + | HEAD | TAIL | LEN -> true + | _ -> false + +let pp fmt u = + let s = Format.fprintf fmt "@[%s@]" in + match u with + | NOT -> s "not" + | HEAD -> s "hd" + | TAIL -> s "tl" + | LEN -> s "len" + | REV -> s "rev" + +let str = Format.asprintf "%a" pp diff --git a/wislfp/lib/syntax/WUnOp.mli b/wislfp/lib/syntax/WUnOp.mli new file mode 100644 index 000000000..8262b4bde --- /dev/null +++ b/wislfp/lib/syntax/WUnOp.mli @@ -0,0 +1,5 @@ +type t = NOT | LEN | REV | HEAD | TAIL + +val is_logic_only : t -> bool +val pp : Format.formatter -> t -> unit +val str : t -> string diff --git a/wislfp/lib/syntax/WVal.ml b/wislfp/lib/syntax/WVal.ml new file mode 100644 index 000000000..c2bd43776 --- /dev/null +++ b/wislfp/lib/syntax/WVal.ml @@ -0,0 +1,23 @@ +type t = + | Bool of bool + | Int of int + | Float of float + | Str of string + | Null + | VList of t list + +let rec pp fmt v = + match v with + | Bool true -> Format.fprintf fmt "@[%s@]" "true" + | Bool false -> Format.fprintf fmt "@[%s@]" "false" + | Int n -> Format.fprintf fmt "@[%i@]" n + | Float x -> Format.fprintf fmt "@[%f@]" x + | Str s -> Format.fprintf fmt "@[\"%s\"@]" s + | Null -> Format.fprintf fmt "@[%s@]" "null" + | VList l -> + WPrettyUtils.pp_list ~pre:(format_of_string "@[[") + ~suf:(format_of_string "]@]") + ~empty:(format_of_string "@[nil@]") + pp fmt l + +let str = Format.asprintf "%a" pp diff --git a/wislfp/lib/syntax/WVal.mli b/wislfp/lib/syntax/WVal.mli new file mode 100644 index 000000000..400684e05 --- /dev/null +++ b/wislfp/lib/syntax/WVal.mli @@ -0,0 +1,10 @@ +type t = + | Bool of bool + | Int of int + | Float of float + | Str of string + | Null + | VList of t list + +val pp : Format.formatter -> t -> unit +val str : t -> string diff --git a/wislfp/lib/syntax/dune b/wislfp/lib/syntax/dune new file mode 100644 index 000000000..309f12a82 --- /dev/null +++ b/wislfp/lib/syntax/dune @@ -0,0 +1,4 @@ +(library + (name pwSyntax) + (libraries pwUtils) + (flags :standard -open PwUtils)) diff --git a/wislfp/lib/utils/codeLoc.ml b/wislfp/lib/utils/codeLoc.ml new file mode 100644 index 000000000..08bfb9825 --- /dev/null +++ b/wislfp/lib/utils/codeLoc.ml @@ -0,0 +1,69 @@ +open Lexing + +type t = { loc_start : Lexing.position; loc_end : Lexing.position } + +let curr lexbuf = + let loc_start = lexeme_start_p lexbuf in + let loc_end = lexeme_end_p lexbuf in + { loc_start; loc_end } + +let fname loc = loc.loc_start.pos_fname +let merge lstart lend = { loc_start = lstart.loc_start; loc_end = lend.loc_end } +let get_start l = l.loc_start +let get_end l = l.loc_end +let col pos = pos.pos_cnum - pos.pos_bol + 1 + +let[@warning "-8"] from_str str = + let from_raw_data fname a b c d = + let loc_start = + { pos_fname = fname; pos_lnum = a; pos_bol = 0; pos_cnum = b - 1 } + in + let loc_end = + { pos_fname = fname; pos_lnum = c; pos_bol = 0; pos_cnum = d - 1 } + in + { loc_start; loc_end } + in + let get_numbers s = + let r = Str.regexp "[0-9]+" in + let rec aux np k l = + if np = 0 then List.rev l + else + let i = Str.search_forward r s k in + let ms = Str.matched_string s in + let lnth = String.length ms in + aux (np - 1) (i + lnth) (int_of_string ms :: l) + in + aux 4 0 [] + in + let [ fname; rest ] = Str.split (Str.regexp "--") str in + let [ a; b; c; d ] = get_numbers rest in + from_raw_data fname a b c d + +let str { loc_start; loc_end } = + let start_col = col loc_start in + let end_col = col loc_end in + Printf.sprintf "%s--%i:%i-%i:%i" loc_start.pos_fname loc_start.pos_lnum + start_col loc_end.pos_lnum end_col + +let json_of_pos pos = + let character = col pos in + let line = pos.pos_lnum in + `Assoc [ ("line", `Int (line - 1)); ("character", `Int (character - 1)) ] + +let json { loc_start; loc_end } = + `Assoc [ ("start", json_of_pos loc_start); ("end", json_of_pos loc_end) ] + +let json_with_uri loc = + `Assoc [ ("uri", `String !WConfig.current_uri); ("range", json loc) ] + +let dummy = { loc_start = dummy_pos; loc_end = dummy_pos } + +let to_location (loc : t) : Gillian.Gil_syntax.Location.t = + let to_position loc : Gillian.Gil_syntax.Location.position = + { pos_line = loc.pos_lnum; pos_column = loc.pos_cnum - loc.pos_bol } + in + { + loc_start = to_position loc.loc_start; + loc_end = to_position loc.loc_end; + loc_source = loc.loc_start.pos_fname; + } diff --git a/wislfp/lib/utils/codeLoc.mli b/wislfp/lib/utils/codeLoc.mli new file mode 100644 index 000000000..3534af54a --- /dev/null +++ b/wislfp/lib/utils/codeLoc.mli @@ -0,0 +1,14 @@ +type t + +val curr : Lexing.lexbuf -> t +val fname : t -> string +val get_start : t -> Lexing.position +val get_end : t -> Lexing.position +val str : t -> string +val from_str : string -> t +val json_of_pos : Lexing.position -> Yojson.Safe.t +val json : t -> Yojson.Safe.t +val json_with_uri : t -> Yojson.Safe.t +val merge : t -> t -> t +val dummy : t +val to_location : t -> Gillian.Gil_syntax.Location.t diff --git a/wislfp/lib/utils/dune b/wislfp/lib/utils/dune new file mode 100644 index 000000000..2e6e812ed --- /dev/null +++ b/wislfp/lib/utils/dune @@ -0,0 +1,5 @@ +(library + (name pwUtils) + (libraries yojson str gillian) + (preprocess + (pps ppx_deriving.std ppx_deriving_yojson))) diff --git a/wislfp/lib/utils/generators.ml b/wislfp/lib/utils/generators.ml new file mode 100644 index 000000000..1d16c00b6 --- /dev/null +++ b/wislfp/lib/utils/generators.ml @@ -0,0 +1,24 @@ +(* id generator for AST *) +let curr_id = ref 0 + +let gen_id () = + let nid = !curr_id in + curr_id := !curr_id + 1; + nid + +(* label/var id generator *) +(* Maps label prefix and function name/gvar to current label/var id *) +let idHash = Hashtbl.create 1 + +let gen_str fname pre = + let curr_id = + match Hashtbl.find_opt idHash (fname, pre) with + | Some x -> x + | None -> 0 + in + let () = Hashtbl.replace idHash (fname, pre) (curr_id + 1) in + pre ^ string_of_int curr_id + +let reset () = + curr_id := 0; + Hashtbl.reset idHash diff --git a/wislfp/lib/utils/generators.mli b/wislfp/lib/utils/generators.mli new file mode 100644 index 000000000..e84b1e7f8 --- /dev/null +++ b/wislfp/lib/utils/generators.mli @@ -0,0 +1,10 @@ +(** generates a new random id *) +val gen_id : unit -> int + +(** Generates a new string with prefix + @param fname Function name, context in which you create labels and variables + @param pre Prefix for the variable/label name +*) +val gen_str : string -> string -> string + +val reset : unit -> unit diff --git a/wislfp/lib/utils/visitorUtils.ml b/wislfp/lib/utils/visitorUtils.ml new file mode 100644 index 000000000..e570071bd --- /dev/null +++ b/wislfp/lib/utils/visitorUtils.ml @@ -0,0 +1,20 @@ +let ( |>> ) ast_el (getter, target) = + match ast_el with + | `None -> getter target + | some -> some + +let list_visitor_builder getter id = + let rec aux lst = + match lst with + | [] -> `None + | el :: r -> getter id el |>> (aux, r) + in + aux + +let list_visitor_builder2 getter id = + let rec aux lst = + match lst with + | [] -> `None + | (_, el) :: r -> getter id el |>> (aux, r) + in + aux diff --git a/wislfp/lib/utils/visitorUtils.mli b/wislfp/lib/utils/visitorUtils.mli new file mode 100644 index 000000000..61942b43b --- /dev/null +++ b/wislfp/lib/utils/visitorUtils.mli @@ -0,0 +1,7 @@ +val ( |>> ) : ([> `None ] as 'a) -> ('b -> 'a) * 'b -> 'a + +val list_visitor_builder : + (int -> 'a -> ([> `None ] as 'b)) -> int -> 'a list -> 'b + +val list_visitor_builder2 : + (int -> 'a -> ([> `None ] as 'b)) -> int -> ('c * 'a) list -> 'b diff --git a/wislfp/lib/utils/wBranchCase.ml b/wislfp/lib/utils/wBranchCase.ml new file mode 100644 index 000000000..8ee335a18 --- /dev/null +++ b/wislfp/lib/utils/wBranchCase.ml @@ -0,0 +1 @@ +type t = IfElse of bool | LCmd of int | Gil of int [@@deriving yojson] diff --git a/wislfp/lib/utils/wConfig.ml b/wislfp/lib/utils/wConfig.ml new file mode 100644 index 000000000..c6b95e0e8 --- /dev/null +++ b/wislfp/lib/utils/wConfig.ml @@ -0,0 +1,4 @@ +let error_lab = "elab" +let current_uri = ref "test.wisl" +let debug_mode = ref false +let import_env_var = "WISLFP_RUNTIME_PATH" diff --git a/wislfp/lib/utils/wConfig.mli b/wislfp/lib/utils/wConfig.mli new file mode 100644 index 000000000..81f02e0fb --- /dev/null +++ b/wislfp/lib/utils/wConfig.mli @@ -0,0 +1,4 @@ +val error_lab : string +val current_uri : string ref +val debug_mode : bool ref +val import_env_var : string diff --git a/wislfp/lib/utils/wErrors.ml b/wislfp/lib/utils/wErrors.ml new file mode 100644 index 000000000..569dd1e9d --- /dev/null +++ b/wislfp/lib/utils/wErrors.ml @@ -0,0 +1,104 @@ +let consistency_errors = ref false + +type severity = SevError | SevWarning | SevInformation | SevHint + +let int_of_severity = function + | SevError -> 1 + | SevWarning -> 2 + | SevInformation -> 3 + | SevHint -> 4 + +type related_info_t = { rel_range : CodeLoc.t; rel_msg : string } + +type t = { + range : CodeLoc.t; + message : string; + code : string; + severity : severity; + related_information : related_info_t list; + function_name : string; +} + +type res_t = (unit, t) result + +type error_code_t = + | UndefinedProp + | ExtensibilityError + | UndefinedVar + | SyntaxError + | MissingResource + | UnconsistentStmtBloc + | FunctionNotVerified + | UndefinedFunction + | UndefinedLemma + | MissingInvariant + +let str_error_code = function + | UndefinedProp -> "UndefinedProp" + | ExtensibilityError -> "ExtensibilityError" + | UndefinedVar -> "UndefinedVar" + | SyntaxError -> "SyntaxError" + | MissingResource -> "MissingResource" + | UnconsistentStmtBloc -> "UnconsistentStmtBloc" + | FunctionNotVerified -> "FunctionNotVerified" + | UndefinedFunction -> "UndefinedFonction" + | UndefinedLemma -> "UndefinedLemma" + | MissingInvariant -> "MissingInvariant" + +let get_errors results = + let rec get_errors' errs = function + | [] -> errs + | Ok _ :: r -> get_errors' errs r + | Error e :: r -> get_errors' (e :: errs) r + in + get_errors' [] results + +let build_consistency_error message range function_name = + let code = str_error_code UnconsistentStmtBloc in + let severity = SevError in + let related_information = [] in + { message; range; code; severity; related_information; function_name } + +let build_warning_not_called range function_name = + let code = str_error_code FunctionNotVerified in + let message = + "This function is never verified because it has no specification and is \ + never called from a function that is verified" + in + let severity = SevWarning in + let related_information = [] in + { code; message; severity; related_information; range; function_name } + +let build_warning_invariant range = + let code = str_error_code MissingInvariant in + let message = + "This while loop will certainly need an invariant in order to be verified \ + correctly" + in + let severity = SevWarning in + let related_information = [] in + { code; message; severity; related_information; range; function_name = "" } + +let build_err_string error_code id loc message = + Format.sprintf "%s;%i;%s;%s" + (str_error_code error_code) + id (CodeLoc.str loc) message + +let json_related { rel_range; rel_msg } = + `Assoc + [ + ("message", `String rel_msg); ("location", CodeLoc.json_with_uri rel_range); + ] + +let json_related_list l = `List (List.map json_related l) + +let json { range; message; code; severity; related_information; _ } = + `Assoc + [ + ("range", CodeLoc.json range); + ("message", `String message); + ("code", `String code); + ("source", `String "wisl-verify"); + ("severity", `Int (int_of_severity severity)); + ("relatedInformation", json_related_list related_information); + ] diff --git a/wislfp/lib/utils/wErrors.mli b/wislfp/lib/utils/wErrors.mli new file mode 100644 index 000000000..f4fba6a08 --- /dev/null +++ b/wislfp/lib/utils/wErrors.mli @@ -0,0 +1,36 @@ +val consistency_errors : bool ref + +type severity = SevError | SevWarning | SevInformation | SevHint +type related_info_t = { rel_range : CodeLoc.t; rel_msg : string } + +type t = { + range : CodeLoc.t; + message : string; + code : string; + severity : severity; + related_information : related_info_t list; + function_name : string; +} + +type error_code_t = + | UndefinedProp + | ExtensibilityError + | UndefinedVar + | SyntaxError + | MissingResource + | UnconsistentStmtBloc + | FunctionNotVerified + | UndefinedFunction + | UndefinedLemma + | MissingInvariant + +val str_error_code : error_code_t -> string + +type res_t = (unit, t) result + +val build_warning_not_called : CodeLoc.t -> string -> t +val get_errors : res_t list -> t list +val json : t -> Yojson.Safe.t +val build_err_string : error_code_t -> int -> CodeLoc.t -> string -> string +val build_consistency_error : string -> CodeLoc.t -> string -> t +val build_warning_invariant : CodeLoc.t -> t diff --git a/wislfp/lib/utils/wPrettyUtils.ml b/wislfp/lib/utils/wPrettyUtils.ml new file mode 100644 index 000000000..604feb537 --- /dev/null +++ b/wislfp/lib/utils/wPrettyUtils.ml @@ -0,0 +1,24 @@ +open Format + +let pp_list + ?((* list pretty-printer from frama-c *) + pre = format_of_string "@[") + ?(sep = format_of_string ", ") + ?(last = sep) + ?(suf = format_of_string "@]") + ?(empty = format_of_string "") + pp_elt + f + l = + let rec aux f = function + | [] -> assert false + | [ e ] -> fprintf f "%a" pp_elt e + | [ e1; e2 ] -> fprintf f "%a%(%)%a" pp_elt e1 last pp_elt e2 + | e :: l -> fprintf f "%a%(%)%a" pp_elt e sep aux l + in + match l with + | [] -> Format.fprintf f "%(%)" empty + | _ :: _ as l -> Format.fprintf f "%(%)%a%(%)" pre aux l suf + +let to_str pp = function + | v -> Format.asprintf "%a" pp v diff --git a/wislfp/lib/utils/wPrettyUtils.mli b/wislfp/lib/utils/wPrettyUtils.mli new file mode 100644 index 000000000..36acc2665 --- /dev/null +++ b/wislfp/lib/utils/wPrettyUtils.mli @@ -0,0 +1,12 @@ +val pp_list : + ?pre:('a, 'b, 'c, 'd, 'd, 'a) format6 -> + ?sep:('e, 'f, 'g, 'h, 'h, 'e) format6 -> + ?last:('e, 'f, 'g, 'h, 'h, 'e) format6 -> + ?suf:('i, 'j, 'k, 'l, 'l, 'i) format6 -> + ?empty:('m, 'n, 'o, 'p, 'p, 'm) format6 -> + (Format.formatter -> 'q -> unit) -> + Format.formatter -> + 'q list -> + unit + +val to_str : (Format.formatter -> 'a -> unit) -> 'a -> string diff --git a/wislfp/runtime/dune b/wislfp/runtime/dune new file mode 100644 index 000000000..03566e456 --- /dev/null +++ b/wislfp/runtime/dune @@ -0,0 +1,4 @@ +(install + (files wisl_core.gil wisl_pointer_arith.gil) + (section share) + (package wislfp)) diff --git a/wislfp/runtime/wisl_core.gil b/wislfp/runtime/wisl_core.gil new file mode 100644 index 000000000..e388927b6 --- /dev/null +++ b/wislfp/runtime/wisl_core.gil @@ -0,0 +1,12 @@ +#internal + +(******** PREDICATES REGARDING CELLS ********) + +(* ptr -> value in WISL *) +pred i__pred_cell (+ptr: List, value): + (ptr == {{ #loc, #offset }}) * + (#loc, #offset; value); + +pred freed(+ptr: List): + (ptr == {{ #l, 0i }}) * types(#l: Obj) * + (#l;); diff --git a/wislfp/runtime/wisl_pointer_arith.gil b/wislfp/runtime/wisl_pointer_arith.gil new file mode 100644 index 000000000..d4b9e8f01 --- /dev/null +++ b/wislfp/runtime/wisl_pointer_arith.gil @@ -0,0 +1,138 @@ +#internal + +import "wisl_core.gil"; + +(******** INTERNAL FUNCTIONS REGARDING POINTER AND NUMBER OPERATIONS ********) + +proc i__ptr_add (ptr, add_offset) { + loc := l-nth(ptr, 0i); + offset := l-nth(ptr, 1i); + ret := {{ loc, offset i+ add_offset }}; + return +}; + +proc i__add (el, er) { + goto [((typeOf el) = List) and ((typeOf er) = Int)] lip linp; + (* Left is a pointer and right is a number *) + lip: ret := "i__ptr_add" (el, er); + return; + (* Left is not a pointer *) + linp: goto [((typeOf er) = List) and ((typeOf el) = Int)] rip rinp; + (* Right is a pointer and left is a number *) + rip: ret := "i__ptr_add" (er, el); + return; + (* Both left and right are numbers *) + rinp: goto [((typeOf el) = Int) and ((typeOf el) = Int)] nadd err; + nadd: ret := el i+ er; + return; + (* Incorrect types *) + err: err_msg := "Addition: Incorrect Types"; + fail [err_msg] (el, er) +}; + +proc i__minus (el, er) { + goto [(typeOf el) = List] lip linp; + (* Left is a pointer *) + lip: mer := i- er; + ret := "i__ptr_add" (el, mer); + goto end; + (* Left is not a pointer *) + linp: ret := el i- er; + end: return +}; + + +proc i__leq (el, er) { + goto [(typeOf el) = List] lip linp; + lip: locl := l-nth(el, 0i); (* left is a pointer, we assume both are, otherwise, type error *) + locr := l-nth(er, 0i); + goto [locr = locr] ok nok; + nok: message := "Cannot compare pointers from different blocks"; + fail [message] (locl, locr); + ok: offsetl := l-nth(el, 1i); + offsetr := l-nth(er, 1i); + ret := offsetl i<= offsetr; + return; + linp: ret := el i<= er; (* we assume that both are integer *) + return +}; + +proc i__lt (el, er) { + goto [(typeOf el) = List] lip linp; + lip: locl := l-nth(el, 0i); (* left is a pointer, we assume both are, otherwise, type error *) + locr := l-nth(er, 0i); + goto [locr = locr] ok nok; + nok: message := "Cannot compare these two values"; + fail [message] (locl, locr); + ok: offsetl := l-nth(el, 1i); + offsetr := l-nth(er, 1i); + ret := offsetl i< offsetr; + return; + linp: ret := el i< er; (* we assume that both are integer *) + return +}; + +proc i__geq (el, er) { + goto [(typeOf el) = List] lip linp; + lip: locl := l-nth(el, 0i); (* left is a pointer, we assume both are, otherwise, type error *) + locr := l-nth(er, 0i); + goto [locr = locr] ok nok; + nok: message := "Cannot compare these two values"; + fail [message] (locl, locr); + ok: offsetl := l-nth(el, 1i); + offsetr := l-nth(er, 1i); + ret := not (offsetl i< offsetr); + return; + linp: ret := not (el i< er); (* we assume that both are integer *) + return +}; + +proc i__gt (el, er) { + goto [(typeOf el) = List] lip linp; + lip: locl := l-nth(el, 0i); (* left is a pointer, we assume both are, otherwise, type error *) + locr := l-nth(er, 0i); + goto [locr = locr] ok nok; + nok: message := "Cannot compare these two values"; + fail [message] (locl, locr); + ok: offsetl := l-nth(el, 1i); + offsetr := l-nth(er, 1i); + ret := not (offsetl i<= offsetr); + return; + linp: ret := not (el i<= er); (* we assume that both are integer *) + return +}; + + +(******** PREDICATES REGARDING POINTER AND NUMBER OPERATIONS ********) + +(* i__pred_add(x, y, z) is true if executing i__add(x, y) would return z *) +pred i__pred_add (+el, +er, out): + types(el: List, er: Int) * (el == {{ #loc, #offset }}) * (out == {{ #loc, #offset i+ er }}), + types(er: List, el: Int) * (er == {{ #loc, #offset}}) * (out == {{ #loc, #offset i+ el }}), + types(er: Int, el: Int) * (out == er i+ el); + +(* i__pred_minus(x, y, z) is true if executing i__minus(x, y) would return z *) +pred i__pred_minus (+el, +er, out): + types(el: List, er: Int) * (el == {{ #loc, #offset }}) * (out == {{ #loc, #offset i- er }}), + types(er: Int, el: Int) * (out == el i- er); + +(* i__pred_lt(x, y, z) is true if executing i__lt(x, y) would return z *) +pred i__pred_lt (+el, +er, out): + types(el: List, er: List) * (el == {{ #locl, #offsetl }}) * (er == {{ #locr, #offsetr }}) * (#locr == #locl) * (out == (#offsetl i< #offsetr)), + types(el: Int, er: Int) * (out == (el i< er)); + +(* i__pred_gt(x, y, z) is true if executing i__gt(x, y) would return z *) +pred i__pred_gt (+el, +er, out): + types(el: List, er: List) * (el == {{ #locl, #offsetl }}) * (er == {{ #locr, #offsetr }}) * (#locr == #locl) * (out == (not (#offsetl i<= #offsetr))), + types(el: Int, er: Int) * (out == (not (el i<= er))); + +(* i__pred_leq(x, y, z) is true if executing i__leq(x, y) would return z *) +pred i__pred_leq (+el, +er, out): + types(el: List, er: List) * (el == {{ #locl, #offsetl }}) * (er == {{ #locr, #offsetr }}) * (#locr == #locl) * (out == (#offsetl i<= #offsetr)), + types(el: Int, er: Int) * (out == (el i<= er)); + +(* i__pred_geq(x, y, z) is true if executing i__geq(x, y) would return z *) +pred i__pred_geq (+el, +er, out): + types(el: List, er: List) * (el == {{ #locl, #offsetl }}) * (er == {{ #locr, #offsetr }}) * (#locr == #locl) * (out == (not (#offsetl i< #offsetr))), + types(el: Int, er: Int) * (out == (not (el i< er))); + diff --git a/wislfp/scripts/quicktests.sh b/wislfp/scripts/quicktests.sh new file mode 100755 index 000000000..0954f174c --- /dev/null +++ b/wislfp/scripts/quicktests.sh @@ -0,0 +1,26 @@ +FINAL_RETURN=0 + +esy x true > /dev/null 2>&1 +esy exec-env > exec.env +source exec.env + +verify () { + echo "\nVerifying: $1\n" + wisl verify $1 + rc=$?; if [[ $rc != 0 ]]; then FINAL_RETURN=1; fi +} + +verify_exv () { + echo "\nVerifying: $1\n" + wisl verify --exv $1 + rc=$?; if [[ $rc != 0 ]]; then FINAL_RETURN=1; fi +} + +echo "--- WISL: OX VERIFICATION ---" +verify wisl/examples/SLL_recursive.wisl +verify wisl/examples/DLL_recursive.wisl + +echo "\n\n--- WISL: EXACT VERIFICATION ---" +verify_exv wisl/examples/SLL_ex_ongoing.wisl + +exit $FINAL_RETURN \ No newline at end of file diff --git a/wislfp/scripts/remake.sh b/wislfp/scripts/remake.sh new file mode 100755 index 000000000..523ded5f5 --- /dev/null +++ b/wislfp/scripts/remake.sh @@ -0,0 +1,9 @@ +cd .. +if [[ $1 == '--nomake' ]] +then + echo 'Not recompiling, only resetting env' +else + esy +fi +esy init:env +cd environment \ No newline at end of file diff --git a/wislfp/scripts/setup_environment.sh b/wislfp/scripts/setup_environment.sh new file mode 100755 index 000000000..d71819cd7 --- /dev/null +++ b/wislfp/scripts/setup_environment.sh @@ -0,0 +1,11 @@ +#!/bin/bash + +foldername=${PWD##*/} +if [ "$foldername" != "wisl" ] +then + cd wisl +fi + +mkdir -p environment +cp -r Examples/* environment/ +cp scripts/*.sh environment \ No newline at end of file diff --git a/wislfp/tests/concrete_test.wisl b/wislfp/tests/concrete_test.wisl new file mode 100644 index 000000000..3077aaa91 --- /dev/null +++ b/wislfp/tests/concrete_test.wisl @@ -0,0 +1,9 @@ +function main() { + x := new(2); + [x] := 1; + [x + 1] := 2; + + y := [x]; + z := [x + 1]; + return y + z +} \ No newline at end of file diff --git a/wislfp/tests/concurrent_binary_tree.wisl b/wislfp/tests/concurrent_binary_tree.wisl new file mode 100644 index 000000000..dcc3d5864 --- /dev/null +++ b/wislfp/tests/concurrent_binary_tree.wisl @@ -0,0 +1,143 @@ +// tree holds the list representation of a pre-order traveresal of a binary tree with root at x. +predicate binary_tree(+x, tree, +p: Float) { + (x == null) * (tree == nil); + (x -> (p: #a), (p: #l), (p: #r)) * binary_tree(#l, #left, p) * binary_tree(#r, #right, p) * (tree == #a::(#left @ #right)) +} + +predicate tree_height(+x, h: Int, +p: Float) { + (x == null) * (h == 0); + (x -> (p: #a), (p: #l), (p: #r)) * tree_height(#l, #hl, p) * tree_height(#r, #hr, p) * (#hl >=# #hr) * (h == #hl + 1); + (x -> (p: #a), (p: #l), (p: #r)) * tree_height(#l, #hl, p) * tree_height(#r, #hr, p) * (#hl <# #hr) * (h == #hr + 1) +} + +predicate list_member(+vs, +v, r : Bool){ + (vs == []) * (r == false); + (vs == v :: #rest) * (r == true); + (vs == #v :: #rest) * (! (#v == v)) * list_member(#rest, v, r) +} + +predicate replaced(+vs, +ws, +v, +w) { + (vs == []) * (ws == []); + (vs == v :: #restvs) * (ws == w :: #restws) * replaced(#restvs, #restws, v, w); + (vs == #v :: #restvs) * (ws == #v :: #restws) * (! (#v == v)) * replaced(#restvs, #restws, v, w) +} + +lemma replaced_concat { + statement: + forall vs1, ws1, vs2, ws2, v, w. + replaced(vs1, ws1, v, w) * replaced(vs2, ws2, v, w) |- replaced(vs1 @ vs2, ws1 @ ws2, v, w) + + proof: + unfold replaced(vs1, ws1, v, w); + if (not (vs1 = [])) { + assert {bind: #nv, #nw, #nvs1, #nws1} (vs1 == #nv :: #nvs1) * (ws1 == #nw :: #nws1) * replaced(#nvs1, #nws1, v, w); + apply replaced_concat(#nvs1, #nws1, vs2, ws2, v, w) + } +} + +lemma list_member_concat { + statement: + forall vs1, vs2, v. + list_member(vs1, v, #r1) * list_member(vs2, v, #r2) |- list_member(vs1 @ vs2, v, (#r1 || #r2)) + + proof: + unfold list_member(vs1, v, #r1); + if (not (vs1 = [])) { + if (hd vs1 = v) { + fold list_member(vs1 @ vs2, v, true) + } else { + assert {bind: #nv1, #nvs1, #nr1} (vs1 == #nv1 :: #nvs1) * list_member(#nvs1, v, #nr1); + apply list_member_concat(#nvs1, vs2, v) + } + } +} + +predicate is_int(+a: Int) { + emp +} + +predicate max(+a:Int, +b:Int, c:Int) { + a >=# b /\ c == a; + a <# b /\ c == b +} + +{ (a == #a) * is_int(#a) * (b == #b) * is_int(#b) } +function max(a, b) { + if (a >= b) { + r := a + } else { + r := b + }; + return r +} +{ max(#a, #b, ret) } + +[ spec height_spec: #p ] +{ (t == #t) * binary_tree(#t, #tree, #p) } +function height(t) { + if (t = null) { + r := 0 + } else { + lt := [t + 1]; + rt := [t + 2]; + par { + lh := height(lt) [height_spec: (#p: #p)]; + rh := height(rt) [height_spec: (#p: #p)] + }; + r := max(lh, rh); + r := r + 1 + }; + return r +} +{ tree_height(#t, ret, #p) } + +[ spec find_spec: #p ] +{ (t == #t) * (v == #v) * binary_tree(#t, #tree, #p) } +function find(t, v) { + if (t = null) { + r := false + } else { + x := [t]; + if (x = v) { + r := true + } else { + lt := [t + 1]; + rt := [t + 2]; + par { + is_in_left := find(lt, v) [ find_spec: (#p: #p) ]; + is_in_right := find(rt, v) [ find_spec: (#p: #p) ] + }; + r := is_in_left || is_in_right; + [[assert {bind: #left, #right} binary_tree(lt, #left, #p) * binary_tree(rt, #right, #p)]]; + [[apply list_member_concat(#left, #right, #v)]]; + [[fold list_member(x :: (#left @ #right), #v, r)]] + } + }; + return r +} +{ binary_tree(#t, #tree, #p) * list_member(#tree, #v, ret) } + +{ (t == #t) * (v == #v) * (w == #w) * binary_tree(#t, #tree, 1.0) } +function replace(t, v, w) { + if (t = null) { + skip + } else { + x := [t]; + if (x = v) { + [t] := w + } else { + skip + }; + lt := [t + 1]; + rt := [t + 2]; + [[assert {bind: #left_tree, #right_tree} binary_tree(lt, #left_tree, 1.0) * binary_tree(rt, #right_tree, 1.0)]]; + par { + u := replace(lt, v, w); + u := replace(rt, v, w) + }; + [[assert {bind: #left_r_tree, #right_r_tree} binary_tree(lt, #left_r_tree, 1.0) * binary_tree(rt, #right_r_tree, 1.0)]]; + [[apply replaced_concat(#left_tree, #left_r_tree, #right_tree, #right_r_tree, #v, #w)]] + }; + return 0 +} +{ binary_tree(#t, #r_tree, 1.0) * replaced(#tree, #r_tree, #v, #w) } \ No newline at end of file diff --git a/wislfp/tests/floating_point.wisl b/wislfp/tests/floating_point.wisl new file mode 100644 index 000000000..80e4c7514 --- /dev/null +++ b/wislfp/tests/floating_point.wisl @@ -0,0 +1,61 @@ +predicate points_to_sub(+x, +a: Float, +b: Float) { + (a f>=# b) * (#v == a f- b) * (x -> #v); + (a f<# b) * (#v == b f- a) * (x -> #v) +} + +{ (x == #x) * (y == #y) } +function floating_addition(x, y) { + z := x f+ y; + return z +} +{ ret == (#x f+ #y) } + +{ (x == #x) * (y == #y) } +function floating_subtraction(x, y) { + r := new(1); + if (x f< y) { + z := y f- x + } else { + z := x f- y + }; + [r] := z; + return r +} +{ points_to_sub(ret, #x, #y) } + +{ (x == #x) * (y == #y) } +function floating_multiplication(x, y) { + z := x f* y; + return z +} +{ ret == (#x f* #y) } + +{ (x == #x) * (y == #y) } +function floating_division(x, y) { + z := x f/ y; + return z +} +{ ret == (#x f/ #y) } + +{ (x == #x) * (y == #y) } +function floating_mod(x, y) { + z := x f% y; + return z +} +{ ret == (#x f% #y) } + +{ emp } +function use_float_ops() { + x := 5.5; + y := 2.0; + + r := new(5); + [r] := x f+ y; + [r + 1] := x f- y; + [r + 2] := x f* y; + [r + 3] := x f/ y; + [r + 4] := x f% y; + + return r +} +{ ret -> 7.5, 3.5, 11.0, 2.75, 1.5 } diff --git a/wislfp/tests/lambda_terms.wisl b/wislfp/tests/lambda_terms.wisl new file mode 100644 index 000000000..7b97d535c --- /dev/null +++ b/wislfp/tests/lambda_terms.wisl @@ -0,0 +1,114 @@ +predicate lambda_term(+x, v, t1, t2, type: Int, +p: Float) { + (x -> (p: 0), (p: v), (p: t1)) * (type == 0) * (t2 == null) * lambda_term(t1, #v1, #t11, #t12, #type1, p); + (x -> (p: 1), (p: t1), (p: t2)) * (type == 1) * (v == 0) * lambda_term(t1, #v1, #t11, #t12, #type1, p) * lambda_term(t2, #v2, #t21, #t22, #type2, p); + (x -> (p: 2), (p: v)) * (type == 2) * (t1 == null) * (t2 == null) +} + +predicate is_copy(+x, +y, +p1: Float, +p2: Float, v, t1, t2, type: Int) { + (x -> (p1: 0), (p1: v), (p1: t1)) * (y -> (p2: 0), (p2: v), (p2: #t2)) * (type == 0) * (t2 == null) * is_copy(t1, #t2, p1, p2, #v, #t11, #t12, #type); + (x -> (p1: 1), (p1: t1), (p1: t2)) * (y -> (p2: 1), (p2: #t21), (p2: #t22)) * (type == 1) * (v == 0) * is_copy(t1, #t21, p1, p2, #v1, #t11, #t12, #type1) * is_copy(t2, #t22, p1, p2, #v2, #t_21, #t_22, #type2); + (x -> (p1: 2), (p1: v)) * (y -> (p2: 2), (p2: v)) * (type == 2) * (t1 == null) * (t2 == null) +} + +predicate substituted(+t_in, +t, +v, +p1: Float, +p2: Float, +pt: Float, +t_out) { + (t_in -> (p1: 0), (p1: v), (p1: #t)) * (t_out -> (p2: 0), (p2: v), (p2: #t2)) * is_copy(#t, #t2, p1, p2, #tv, #tt1, #tt2, #type1) * lambda_term(t, #w, #t11, #t12, #type2, pt); + (t_in -> (p1: 0), (p1: #v), (p1: #t)) * (! (#v == v)) * (t_out -> (p2: 0), (p2: #v), (p2: #t_out)) * substituted(#t, t, v, p1, p2, pt, #t_out); + (t_in -> (p1: 1), (p1: #t1), (p1: #t2)) * (t_out -> (p2: 1), (p2: #t1_out), (p2: #t2_out)) * substituted(#t1, t, v, p1, p2, pt f/ 2.0, #t1_out) * substituted(#t2, t, v, p1, p2, pt f/ 2.0, #t2_out); + (t_in -> (p1: 2), (p1: v)) * is_copy(t, t_out, pt, p2, #v, #t1, #t2, #type); + (t_in -> (p1: 2), (p1: #v)) * (! (v == #v)) * (t_out -> (p2: 2), (p2: #v)) * lambda_term(t, #w, #t1, #t2, #type, pt) +} + +lemma split_lambda_term_permission { + statement: + forall x, v, t1, t2, type, p, p1, p2. + (p == p1 f+ p2) * (p1 f># 0.0) * (p2 f># 0.0) * lambda_term(x, v, t1, t2, type, p) |- lambda_term(x, v, t1, t2, type, p1) * lambda_term(x, v, t1, t2, type, p2) + + proof: + unfold lambda_term(x, v, t1, t2, type, p); + if (not (type = 2)) { + if (type = 1) { + assert {bind: #v1, #t11, #t12, #type1, #v2, #t21, #t22, #type2} lambda_term(t1, #v1, #t11, #t12, #type1, p) * lambda_term(t2, #v2, #t21, #t22, #type2, p); + apply split_lambda_term_permission(t1, #v1, #t11, #t12, #type1, p, p1, p2); + apply split_lambda_term_permission(t2, #v2, #t21, #t22, #type2, p, p1, p2) + } else { + assert {bind: #v1, #t11, #t12, #type1} lambda_term(t1, #v1, #t11, #t12, #type1, p); + apply split_lambda_term_permission(t1, #v1, #t11, #t12, #type1, p, p1, p2) + }; + fold lambda_term(x, v, t1, t2, type, p1); + fold lambda_term(x, v, t1, t2, type, p2) + } +} + +[spec copy_spec: #p] +{ (x == #x) * lambda_term(#x, #v, #t1, #t2, #type, #p) } +function copy(x) { + type := [x]; + if (type = 2) { + r := new(2); + v := [x + 1]; + [r + 1] := v + } else { + r := new(3); + if (type = 1) { + t1 := [x + 1]; + t2 := [x + 2]; + par { + r1 := copy(t1) [copy_spec: (#p: #p)]; + r2 := copy(t2) [copy_spec: (#p: #p)] + }; + [r + 1] := r1; + [r + 2] := r2 + } else { + v := [x + 1]; + t1 := [x + 2]; + [r + 1] := v; + r1 := copy(t1) [copy_spec: (#p: #p)]; + [r + 2] := r1 + } + }; + [r] := type; + return r +} +{ is_copy(#x, ret, #p, 1.0, #v, #t1, #t2, #type) } + +[spec subst_spec: #px, #py] +{ (x == #x) * (y == #y) * (v == #v) * lambda_term(#x, #vx, #tx1, #tx2, #type_x, #px) * lambda_term(#y, #vy, #ty1, #ty2, #type_y, #py) } +function subst(x, y, v) { + type := [x]; + if (type = 2) { + w := [x + 1]; + if (v = w) { + r := copy(y)[copy_spec: (#p: #py)] + } else { + r := copy(x)[copy_spec: (#p: #px)]; + [[unfold is_copy(#x, r, #px, 1.0, #vx, #tx1, #tx2, #type_x)]] + } + } else { + r := new(3); + [r] := type; + if (type = 1) { + t1 := [x + 1]; + t2 := [x + 2]; + [[assert {bind: #py_half} (#py_half == #py f/ 2.0)]]; + [[apply split_lambda_term_permission(#y, #vy, #ty1, #ty2, #type_y, #py, #py_half, #py_half)]]; + par { + ct1 := subst(t1, y, v)[subst_spec: (#px: #px), (#py: #py_half)]; + ct2 := subst(t2, y, v)[subst_spec: (#px: #px), (#py: #py_half)] + }; + [r + 1] := ct1; + [r + 2] := ct2 + } else { + w := [x + 1]; + t := [x + 2]; + if (v = w) { + ct := copy(t)[copy_spec: (#p: #px)] + } else { + ct := subst(t, y, v)[subst_spec: (#px: #px), (#py: #py)] + }; + [r + 1] := w; + [r + 2] := ct + } + }; + return r +} +{ substituted(#x, #y, #v, #px, 1.0, #py, ret) } \ No newline at end of file diff --git a/wislfp/tests/simple_concurrency.wisl b/wislfp/tests/simple_concurrency.wisl new file mode 100644 index 000000000..b00105b3a --- /dev/null +++ b/wislfp/tests/simple_concurrency.wisl @@ -0,0 +1,96 @@ +predicate is_zero(+x, y) { + (x == 0) * (y == 1); + (! (x == 0)) * (y == 0) +} + +predicate is_int(+x: Int) { + emp +} + +{ (x == #x) * (p == #p) * (#p f<=# 1.0) * (#x -> (#p: #v)) } +function read(x, p) { + n := [x]; + if (n = 0) { + r := 1 + } else { + r := 0 + }; + return r +} +{ is_zero(#v, ret) * (#x -> (#p: #v)) } + +{ (x == #x) * (v == #v) * (#x -> (1.0: #y))} +function write(x, v) { + [x] := v; + return 0 +} +{ (ret == 0) * (#x -> #v) } + +//should fail +[spec incorrect_write: #p] +{ (x == #x) * (v == #v) * (#p f<=# 1.0) * (#x -> (#p: #v))} +function incorrect_write(x, v) { + [x] := v; + return 0 +} +{ (ret == 0) * (#x -> #v) } + +{ (x == #x) * (p == #p) * (w == #w) * is_int(#w) * is_int(#v) * (#p f<=# 1.0) * (#x -> (#p: #v)) } +function read_and_add(x, p, w) { + n := [x]; + m := n + w; + return m +} +{ (#x -> (#p: #v)) * (ret == #v + #w) } + +{ emp } +function conc_disjoint_reads() { + x := new(2); + [x] := 0; + [x + 1] := 0; + par { + fst := read(x, 0.5); + snd := read(x + 1, 0.5) + }; + [x] := fst; + [x + 1] := snd; + return x +} +{ ret -> 1, 1 } + +{ emp } +function conc_disjoint_writes() { + x := new(3); + par { + u := write(x, 1); + u := write(x + 1, 2); + u := write(x + 2, 3) + }; + return x +} +{ ret -> 1, 2, 3 } + +{ (x == #x) * (#x -> #v) * is_int(#v) } +function conc_reads_same_loc(x) { + y := new(2); + par { + fst := read_and_add(x, 0.5, 5); + snd := read_and_add(x, 0.5, 10) + }; + [y] := fst; + [y + 1] := snd; + return y +} +{ (#x -> #v) * ret -> #v + 5, #v + 10} + +// should fail +{ emp } +function conc_writes_same_loc() { + x := new(1); + par { + u := write(x, 2); + u := write(x, 3) + }; + return x +} +{ ret == 2 \/ ret == 3 } \ No newline at end of file