From 6e2bcc7c4ea013cf3dca566d239f9adb4064b8d7 Mon Sep 17 00:00:00 2001 From: Rini Banerjee <26858592+rbanerjee20@users.noreply.github.com> Date: Thu, 31 Oct 2024 15:23:40 +0000 Subject: [PATCH 001/148] [CN-exec/CN-test-gen] Records fix (#677) --- backend/cn/lib/cn_internal_to_ail.ml | 52 ++++++++++++----------- backend/cn/lib/cn_internal_to_ail.mli | 2 +- backend/cn/lib/executable_spec_records.ml | 25 ++++++++--- 3 files changed, 46 insertions(+), 33 deletions(-) diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 29f2a9639..683db6226 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -43,19 +43,17 @@ let rec cn_base_type_to_bt = function module MembersKey = struct - type t = (Id.t * Sym.t cn_base_type) list + type t = (Id.t * BT.t) list let rec compare (ms : t) ms' = match (ms, ms') with | [], [] -> 0 | _, [] -> 1 | [], _ -> -1 - | (id, cn_bt) :: ms, (id', cn_bt') :: ms' -> + | (id, bt) :: ms, (id', bt') :: ms' -> let c = String.compare (Id.s id) (Id.s id') in if c == 0 then ( - let c' = - BaseTypes.compare (cn_base_type_to_bt cn_bt) (cn_base_type_to_bt cn_bt') - in + let c' = BaseTypes.compare bt bt' in if c' == 0 then compare ms ms' else @@ -171,8 +169,8 @@ let str_of_bt_bitvector_type sign size = let augment_record_map ?cn_sym bt = let sym_prefix = match cn_sym with Some sym' -> sym' | None -> Sym.fresh () in - match bt_to_cn_base_type bt with - | CN_record members -> + match bt with + | BT.Record members -> (* Augment records map if entry does not exist already *) if not (RecordMap.mem members !records) then ( let sym' = generate_sym_with_suffix ~suffix:"_record" sym_prefix in @@ -188,10 +186,7 @@ let lookup_records_map members = ("Record not found in map (" ^ String.concat ", " - (List.map - (fun (x, cbt) -> - Pp.(plain (BT.pp (cn_base_type_to_bt cbt) ^^ space ^^ Id.pp x))) - members) + (List.map (fun (x, bt) -> Pp.(plain (BT.pp bt ^^ space ^^ Id.pp x))) members) ^ ")") @@ -214,7 +209,10 @@ let rec cn_to_ail_base_type ?pred_sym:(_ = None) cn_typ = (* gets replaced with typedef anyway (TODO: clean up) *) | CN_struct sym -> C.(Struct (generate_sym_with_suffix ~suffix:"_cn" sym)) | CN_record members -> - let sym = lookup_records_map members in + let sym = + lookup_records_map + (List.map (fun (id, bt) -> (id, cn_base_type_to_bt bt)) members) + in Struct sym (* Every struct is converted into a struct pointer *) | CN_datatype sym -> Struct sym @@ -362,6 +360,9 @@ let get_underscored_typedef_string_from_bt ?(is_record = false) bt = let suffix = if is_record then "" else "_cn" in let cn_sym = generate_sym_with_suffix ~suffix sym in Some ("struct_" ^ Sym.pp_string cn_sym) + | BT.Record ms -> + let sym = lookup_records_map ms in + Some ("struct_" ^ Sym.pp_string sym) | _ -> None) @@ -1120,9 +1121,7 @@ let rec cn_to_ail_expr_aux_internal let assign_stat = A.(AilSexpr (mk_expr (AilEassign (mk_expr ail_memberof, e)))) in (b, s, assign_stat) in - let transformed_ms = - List.map (fun (id, it) -> (id, bt_to_cn_base_type (IT.bt it))) ms - in + let transformed_ms = List.map (fun (id, it) -> (id, IT.bt it)) ms in let sym_name = lookup_records_map transformed_ms in let ctype_ = C.(Pointer (empty_qualifiers, mk_ctype (Struct sym_name))) in let res_binding = create_binding res_sym (mk_ctype ctype_) in @@ -1601,9 +1600,7 @@ let cn_to_ail_expr_internal_with_pred_name let create_member (ctype, id) = (id, (empty_attributes, None, empty_qualifiers, ctype)) let generate_tag_definition dt_members = - let ail_dt_members = - List.map (fun (id, cn_type) -> (cn_to_ail_base_type cn_type, id)) dt_members - in + let ail_dt_members = List.map (fun (id, bt) -> (bt_to_ail_ctype bt, id)) dt_members in (* TODO: Check if something called tag already exists *) let members = List.map create_member ail_dt_members in C.(StructDef (members, None)) @@ -1728,9 +1725,13 @@ let cn_to_ail_datatype ?(first = false) (cn_datatype : cn_datatype) create_member (mk_ctype cntype_pointer, Id.id "cntype") ] in - let structs = - List.map (fun c -> generate_struct_definition c) cn_datatype.cn_dt_cases + let bt_cases = + List.map + (fun (sym, ms) -> + (sym, List.map (fun (id, cn_t) -> (id, cn_base_type_to_bt cn_t)) ms)) + cn_datatype.cn_dt_cases in + let structs = List.map (fun c -> generate_struct_definition c) bt_cases in let structs = if first then ( let generic_dt_struct = @@ -1993,7 +1994,7 @@ let generate_datatype_default_function (cn_datatype : cn_datatype) = | Some member_ctype_str -> "default_" ^ member_ctype_str | None -> Printf.printf "%s\n" (Pp.plain (BT.pp bt)); - failwith "no underscored typedef string found" + failwith "Datatype default function: no underscored typedef string found" in let fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty default_fun_str)), [])) @@ -2185,7 +2186,7 @@ let generate_struct_default_function | Some member_ctype_str -> "default_" ^ member_ctype_str | None -> Printf.printf "%s\n" (Pp.plain (BT.pp bt)); - failwith "no underscored typedef string found" + failwith "Struct default function: no underscored typedef string found" in let fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty default_fun_str)), [])) @@ -2474,6 +2475,7 @@ let generate_record_default_function _dts (sym, (members : BT.member_types)) : (A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition) list = let cn_sym = sym in + (* Printf.printf "Record sym: %s\n" (Sym.pp_string cn_sym); *) let fn_str = "default_struct_" ^ Sym.pp_string cn_sym in let cn_struct_ctype = C.(Struct cn_sym) in let cn_struct_ptr_ctype = @@ -2487,6 +2489,7 @@ let generate_record_default_function _dts (sym, (members : BT.member_types)) let ret_ident = A.(AilEident ret_sym) in (* Function body *) let generate_member_default_assign (id, bt) = + (* Printf.printf "Member: %s\n" (Id.pp_string id); *) let lhs = A.(AilEmemberofptr (mk_expr ret_ident, id)) in let member_ctype_str_opt = get_underscored_typedef_string_from_bt bt in let default_fun_str = @@ -2494,7 +2497,7 @@ let generate_record_default_function _dts (sym, (members : BT.member_types)) | Some member_ctype_str -> "default_" ^ member_ctype_str | None -> Printf.printf "%s\n" (Pp.plain (BT.pp bt)); - failwith "no underscored typedef string found" + failwith "Record default function: no underscored typedef string found" in let fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty default_fun_str)), [])) @@ -2918,9 +2921,8 @@ let cn_to_ail_logical_constraint let rec generate_record_opt pred_sym = function | BT.Record members -> - let members' = List.map (fun (id, bt) -> (id, bt_to_cn_base_type bt)) members in let record_sym = generate_sym_with_suffix ~suffix:"_record" pred_sym in - Some (generate_struct_definition ~lc:false (record_sym, members')) + Some (generate_struct_definition ~lc:false (record_sym, members)) | BT.Tuple ts -> let members = List.map (fun t -> (create_id_from_sym (Sym.fresh ()), t)) ts in generate_record_opt pred_sym (BT.Record members) diff --git a/backend/cn/lib/cn_internal_to_ail.mli b/backend/cn/lib/cn_internal_to_ail.mli index a25332ac4..841db0085 100644 --- a/backend/cn/lib/cn_internal_to_ail.mli +++ b/backend/cn/lib/cn_internal_to_ail.mli @@ -6,7 +6,7 @@ module BT = BaseTypes val ownership_ctypes : C.ctype list ref module MembersKey : sig - type t = (Id.t * Sym.t CF.Cn.cn_base_type) list + type t = (Id.t * BT.t) list val compare : t -> t -> int end diff --git a/backend/cn/lib/executable_spec_records.ml b/backend/cn/lib/executable_spec_records.ml index 3e6deb460..11f571e33 100644 --- a/backend/cn/lib/executable_spec_records.ml +++ b/backend/cn/lib/executable_spec_records.ml @@ -118,11 +118,14 @@ let add_records_to_map_from_instrumentation (i : Core_to_mucore.instrumentation) match i.internal with Some instr -> aux_at instr | None -> () -(* Populate record table *) -let populate_record_map - (instrumentation : Core_to_mucore.instrumentation list) - (prog5 : unit Mucore.file) - = +let add_records_to_map_from_fns_and_preds (prog5 : unit Mucore.file) = + let populate cn_sym bt = + Cn_internal_to_ail.augment_record_map ~cn_sym bt; + match bt with + | BT.Record members -> + List.iter Cn_internal_to_ail.augment_record_map (List.map snd members) + | _ -> () + in let fun_syms_and_ret_types = List.map (fun (sym, (def : LogicalFunctions.definition)) -> (sym, def.return_bt)) @@ -134,6 +137,14 @@ let populate_record_map prog5.resource_predicates in List.iter - (fun (cn_sym, bt) -> Cn_internal_to_ail.augment_record_map ~cn_sym bt) - (fun_syms_and_ret_types @ pred_syms_and_ret_types); + (fun (cn_sym, bt) -> populate cn_sym bt) + (fun_syms_and_ret_types @ pred_syms_and_ret_types) + + +(* Populate record table *) +let populate_record_map + (instrumentation : Core_to_mucore.instrumentation list) + (prog5 : unit Mucore.file) + = + add_records_to_map_from_fns_and_preds prog5; List.iter add_records_to_map_from_instrumentation instrumentation From b9fced21f28cb8e552384f4afa7cd8cb0bb7fddc Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 31 Oct 2024 08:32:28 -0400 Subject: [PATCH 002/148] [CN-Test-Gen] Don't flatten `pick`s DESTROYS performance when there are many nested picks. It appears the urn operations are what become so slow. --- backend/cn/lib/testGeneration/genOptimize.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 2c77e8fa4..69bca7478 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -986,7 +986,8 @@ module BranchPruning = struct let aux (gt : GT.t) : GT.t = match gt with | GT (Pick [ (_, gt') ], _, _) -> gt' - | GT (Pick wgts, _, loc_pick) -> + (* TODO: Understand why this is so bad *) + (* | GT (Pick wgts, _, loc_pick) -> let rec aux'' (wgts : (Z.t * GT.t) list) : (Z.t * GT.t) list = match List.find_index (fun (_, gt') -> GT.is_pick gt') wgts with | Some i -> @@ -1011,7 +1012,7 @@ module BranchPruning = struct | _ -> failwith ("unreachable @ " ^ __LOC__)) | None -> wgts in - GT.pick_ (aux'' wgts) loc_pick + GT.pick_ (aux'' wgts) loc_pick *) | GT (ITE (it_cond, gt_then, gt_else), _, _) -> if IT.is_true it_cond then gt_then From d3c6a7787af2cf49e49c7cfae0e6dd2e14021cb1 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 31 Oct 2024 08:33:36 -0400 Subject: [PATCH 003/148] [CN-Test-Gen] Add mechanism for discarded runs Instead of instantly giving up after a single failure --- backend/cn/lib/testGeneration/specTests.ml | 12 +++++++++- runtime/libcn/include/cn-testing/test.h | 28 ++++++++++++++++------ runtime/libcn/src/cn-testing/test.c | 18 +++++++++++++- 3 files changed, 49 insertions(+), 9 deletions(-) diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 4cf2f9f1d..a4e426f8e 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -160,7 +160,17 @@ let compile_random_test_case ^^ parens (separate (comma ^^ space) - [ Sym.pp inst.fn; int 100; separate_map (comma ^^ space) convert_from args ]) + [ inst.fn_loc + |> Cerb_location.get_filename + |> Option.get + |> Filename.basename + |> String.split_on_char '.' + |> List.hd + |> string; + Sym.pp inst.fn; + int 100; + separate_map (comma ^^ space) convert_from args + ]) ^^ twice hardline diff --git a/runtime/libcn/include/cn-testing/test.h b/runtime/libcn/include/cn-testing/test.h index bb88dc5f1..7f4a324bf 100644 --- a/runtime/libcn/include/cn-testing/test.h +++ b/runtime/libcn/include/cn-testing/test.h @@ -9,6 +9,8 @@ typedef enum cn_test_result cn_test_case_fn(void); void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func); +void print_test_info(char* suite, char* name, int tests, int discards); + #define CN_UNIT_TEST_CASE(Name) \ static jmp_buf buf_##Name; \ \ @@ -28,7 +30,7 @@ void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func); return CN_TEST_PASS; \ } -#define CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Name, Samples, Init, ...) \ +#define CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Suite, Name, Samples, Init, ...) \ static jmp_buf buf_##Name; \ \ void cn_test_##Name##_fail () { \ @@ -42,11 +44,21 @@ void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func); set_cn_exit_cb(&cn_test_##Name##_fail); \ \ cn_gen_rand_checkpoint checkpoint = cn_gen_rand_save(); \ - for (int i = 0; i < Samples; i++) { \ + int i = 0, d = 0; \ + for (; i < Samples; i++) { \ + printf("\r"); \ + print_test_info(#Suite, #Name, i, d); \ CN_TEST_INIT(); \ struct cn_gen_##Name##_record *res = cn_gen_##Name(); \ if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ - return CN_TEST_GEN_FAIL; \ + i--; \ + d++; \ + if (d == 10 * Samples) { \ + printf("\r"); \ + print_test_info(#Suite, #Name, i + 1, d); \ + return CN_TEST_GEN_FAIL; \ + } \ + continue; \ } \ assume_##Name(__VA_ARGS__); \ Init(res); \ @@ -54,16 +66,18 @@ void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func); cn_gen_rand_replace(checkpoint); \ } \ \ + printf("\r"); \ + print_test_info(#Suite, #Name, i, d); \ return CN_TEST_PASS; \ } -#define CN_RANDOM_TEST_CASE_WITH_INIT(Name, Samples, ...) \ +#define CN_RANDOM_TEST_CASE_WITH_INIT(Suite, Name, Samples, ...) \ CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT( \ - Name, Samples, cn_test_##Name##_init, __VA_ARGS__) + Suite, Name, Samples, cn_test_##Name##_init, __VA_ARGS__) -#define CN_RANDOM_TEST_CASE(Name, Samples, ...) \ - CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Name, Samples, , __VA_ARGS__) +#define CN_RANDOM_TEST_CASE(Suite, Name, Samples, ...) \ + CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Suite, Name, Samples, , __VA_ARGS__) int cn_test_main(int argc, char* argv[]); diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index 485854410..cc446a7fc 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -38,6 +38,20 @@ void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func) { }; } +void print_test_info(char* suite, char* name, int tests, int discards) { + if (tests == 0 && discards == 0) { + printf("Testing %s::%s:", suite, name); + } + else if (discards == 0) { + printf("Testing %s::%s: %d runs", suite, name, tests); + } + else { + printf("Testing %s::%s: %d runs; %d discarded", suite, name, tests, discards); + } + + fflush(stdout); +} + int cn_test_main(int argc, char* argv[]) { set_cn_logging_level(CN_LOGGING_NONE); @@ -82,9 +96,11 @@ int cn_test_main(int argc, char* argv[]) { enum cn_test_result results[CN_TEST_MAX_TEST_CASES]; for (int i = 0; i < num_test_cases; i++) { struct cn_test_case* test_case = &test_cases[i]; - printf("Testing %s::%s: ", test_case->suite, test_case->name); + print_test_info(test_case->suite, test_case->name, 0, 0); + fflush(stdout); checkpoints[i] = cn_gen_rand_save(); results[i] = test_case->func(); + printf("\n"); switch (results[i]) { case CN_TEST_PASS: passed++; From ee998b7b6cb4d1fa2fce1c20e8838d79f1129e97 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 31 Oct 2024 09:45:04 -0400 Subject: [PATCH 004/148] [CN-Test-Gen] Settings to test until some timeout Useful for evaluation, such as via Etna --- backend/cn/bin/main.ml | 23 ++++- backend/cn/lib/testGeneration/specTests.ml | 11 ++- .../cn/lib/testGeneration/testGenConfig.ml | 12 ++- .../cn/lib/testGeneration/testGenConfig.mli | 8 +- runtime/libcn/src/cn-testing/test.c | 84 +++++++++++++++---- 5 files changed, 116 insertions(+), 22 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index e12ace41a..d9f620101 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -445,6 +445,8 @@ let run_tests seed logging_level interactive + until_timeout + exit_fast = (* flags *) Cerb_debug.debug_level := debug_level; @@ -493,7 +495,9 @@ let run_tests null_in_every; seed; logging_level; - interactive + interactive; + until_timeout; + exit_fast } in TestGeneration.run @@ -914,6 +918,21 @@ module Testing_flags = struct "Enable interactive features for testing, such as requesting more detailed logs" in Arg.(value & flag & info [ "interactive" ] ~doc) + + + let test_until_timeout = + let doc = + "Keep rerunning tests until the given timeout (in seconds) has been reached" + in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.until_timeout + & info [ "until-timeout" ] ~doc) + + + let test_exit_fast = + let doc = "Stop testing upon finding the first failure" in + Arg.(value & flag & info [ "exit-fast" ] ~doc) end let testing_cmd = @@ -942,6 +961,8 @@ let testing_cmd = $ Testing_flags.test_seed $ Testing_flags.test_logging_level $ Testing_flags.interactive_testing + $ Testing_flags.test_until_timeout + $ Testing_flags.test_exit_fast in let doc = "Generates RapidCheck tests for all functions in [FILE] with CN specifications.\n\ diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index a4e426f8e..95dcee75e 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -443,9 +443,16 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = |> Option.map (fun level -> [ "--logging-level"; string_of_int level ]) |> Option.to_list |> List.flatten) + @ (if Config.is_interactive () then + [ "--interactive" ] + else + []) + @ (match Config.is_until_timeout () with + | Some timeout -> [ "--until-timeout"; string_of_int timeout ] + | None -> []) @ - if Config.is_interactive () then - [ "--interactive" ] + if Config.is_exit_fast () then + [ "--exit-fast" ] else []) in diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index de647740e..4f80f0d0b 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -7,7 +7,9 @@ type t = null_in_every : int option; seed : string option; logging_level : int option; - interactive : bool + interactive : bool; + until_timeout : int option; + exit_fast : bool } let default = @@ -17,7 +19,9 @@ let default = null_in_every = None; seed = None; logging_level = None; - interactive = false + interactive = false; + until_timeout = None; + exit_fast = false } @@ -38,3 +42,7 @@ let has_seed () = !instance.seed let has_logging_level () = !instance.logging_level let is_interactive () = !instance.interactive + +let is_until_timeout () = !instance.until_timeout + +let is_exit_fast () = !instance.exit_fast diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 479c37109..1fe6eaea0 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -7,7 +7,9 @@ type t = null_in_every : int option; seed : string option; logging_level : int option; - interactive : bool + interactive : bool; + until_timeout : int option; + exit_fast : bool } val default : t @@ -27,3 +29,7 @@ val has_seed : unit -> string option val has_logging_level : unit -> int option val is_interactive : unit -> bool + +val is_until_timeout : unit -> int option + +val is_exit_fast : unit -> bool diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index cc446a7fc..6fc3d1637 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -53,12 +53,15 @@ void print_test_info(char* suite, char* name, int tests, int discards) { } int cn_test_main(int argc, char* argv[]) { + int begin_time = time(NULL); set_cn_logging_level(CN_LOGGING_NONE); cn_gen_srand(time(NULL)); uint64_t seed = cn_gen_rand(); int interactive = 0; enum cn_logging_level logging_level = CN_LOGGING_ERROR; + int timeout = 0; + int exit_fast = 0; for (int i = 0; i < argc; i++) { char* arg = argv[i]; @@ -77,50 +80,99 @@ int cn_test_main(int argc, char* argv[]) { set_null_in_every(strtol(argv[i + 1], NULL, 16)); i++; } + else if (strcmp("--until-timeout", arg) == 0) { + timeout = strtol(argv[i + 1], NULL, 10); + i++; + } + else if (strcmp("--exit-fast", arg) == 0) { + exit_fast = 1; + } } if (interactive) { printf("Running in interactive mode\n"); } + if (timeout != 0) { + printf("Running until timeout of %d seconds\n", timeout); + } + printf("Using seed: %016" PRIx64 "\n", seed); cn_gen_srand(seed); cn_gen_rand(); // Junk to get something to make a checkpoint from + cn_gen_rand_checkpoint checkpoints[CN_TEST_MAX_TEST_CASES]; + enum cn_test_result results[CN_TEST_MAX_TEST_CASES] = { CN_TEST_SKIP }; + + int timediff = 0; + + do { + for (int i = 0; i < num_test_cases; i++) { + if (results[i] == CN_TEST_FAIL) { + continue; + } + + struct cn_test_case* test_case = &test_cases[i]; + print_test_info(test_case->suite, test_case->name, 0, 0); + fflush(stdout); + checkpoints[i] = cn_gen_rand_save(); + enum cn_test_result result = test_case->func(); + if (!(results[i] == CN_TEST_PASS && result == CN_TEST_GEN_FAIL)) { + results[i] = result; + } + printf("\n"); + switch (result) { + case CN_TEST_PASS: + printf("PASSED\n"); + break; + case CN_TEST_FAIL: + printf("FAILED\n"); + set_cn_logging_level(logging_level); + cn_gen_rand_restore(checkpoints[i]); + test_case->func(); + set_cn_logging_level(CN_LOGGING_NONE); + break; + case CN_TEST_GEN_FAIL: + printf("FAILED TO GENERATE VALID INPUT\n"); + break; + case CN_TEST_SKIP: + printf("SKIPPED\n"); + break; + } + + if (exit_fast && result == CN_TEST_FAIL) { + goto outside_loop; + } + + if (timeout != 0) { + timediff = time(NULL) - begin_time; + } + } + if (timediff < timeout) { + printf("\n%d seconds remaining, rerunning tests\n\n", timeout - timediff); + } + } while (timediff < timeout); + +outside_loop: + ; int passed = 0; int failed = 0; int errored = 0; int skipped = 0; - cn_gen_rand_checkpoint checkpoints[CN_TEST_MAX_TEST_CASES]; - enum cn_test_result results[CN_TEST_MAX_TEST_CASES]; for (int i = 0; i < num_test_cases; i++) { - struct cn_test_case* test_case = &test_cases[i]; - print_test_info(test_case->suite, test_case->name, 0, 0); - fflush(stdout); - checkpoints[i] = cn_gen_rand_save(); - results[i] = test_case->func(); - printf("\n"); switch (results[i]) { case CN_TEST_PASS: passed++; - printf("PASSED\n"); break; case CN_TEST_FAIL: failed++; - printf("FAILED\n"); - set_cn_logging_level(logging_level); - cn_gen_rand_restore(checkpoints[i]); - test_case->func(); - set_cn_logging_level(CN_LOGGING_NONE); break; case CN_TEST_GEN_FAIL: errored++; - printf("FAILED TO GENERATE VALID INPUT\n"); break; case CN_TEST_SKIP: skipped++; - printf("SKIPPED\n"); break; } } From 884109c1ebcc3e1d3b197d3ac7de5fe5708b45be Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 31 Oct 2024 10:06:23 -0400 Subject: [PATCH 005/148] [CN-Test-Gen] Fix printing glitches --- runtime/libcn/include/cn-testing/test.h | 16 ++++++++++------ runtime/libcn/src/cn-testing/test.c | 10 +++++----- 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/runtime/libcn/include/cn-testing/test.h b/runtime/libcn/include/cn-testing/test.h index 7f4a324bf..7af5a3912 100644 --- a/runtime/libcn/include/cn-testing/test.h +++ b/runtime/libcn/include/cn-testing/test.h @@ -5,7 +5,7 @@ #include #include -typedef enum cn_test_result cn_test_case_fn(void); +typedef enum cn_test_result cn_test_case_fn(int); void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func); @@ -37,7 +37,7 @@ void print_test_info(char* suite, char* name, int tests, int discards); longjmp(buf_##Name, 1); \ } \ \ - enum cn_test_result cn_test_##Name () { \ + enum cn_test_result cn_test_##Name (int printing) { \ if (setjmp(buf_##Name)) { \ return CN_TEST_FAIL; \ } \ @@ -46,8 +46,10 @@ void print_test_info(char* suite, char* name, int tests, int discards); cn_gen_rand_checkpoint checkpoint = cn_gen_rand_save(); \ int i = 0, d = 0; \ for (; i < Samples; i++) { \ - printf("\r"); \ - print_test_info(#Suite, #Name, i, d); \ + if (printing) { \ + printf("\r"); \ + print_test_info(#Suite, #Name, i, d); \ + } \ CN_TEST_INIT(); \ struct cn_gen_##Name##_record *res = cn_gen_##Name(); \ if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ @@ -66,8 +68,10 @@ void print_test_info(char* suite, char* name, int tests, int discards); cn_gen_rand_replace(checkpoint); \ } \ \ - printf("\r"); \ - print_test_info(#Suite, #Name, i, d); \ + if (printing) { \ + printf("\r"); \ + print_test_info(#Suite, #Name, i, d); \ + } \ return CN_TEST_PASS; \ } diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index 6fc3d1637..df96f8e0a 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -8,12 +8,11 @@ #include +#include #include #include #include -typedef enum cn_test_result cn_test_case_fn(void); - struct cn_test_case { char* suite; char* name; @@ -116,7 +115,7 @@ int cn_test_main(int argc, char* argv[]) { print_test_info(test_case->suite, test_case->name, 0, 0); fflush(stdout); checkpoints[i] = cn_gen_rand_save(); - enum cn_test_result result = test_case->func(); + enum cn_test_result result = test_case->func(1); if (!(results[i] == CN_TEST_PASS && result == CN_TEST_GEN_FAIL)) { results[i] = result; } @@ -129,8 +128,9 @@ int cn_test_main(int argc, char* argv[]) { printf("FAILED\n"); set_cn_logging_level(logging_level); cn_gen_rand_restore(checkpoints[i]); - test_case->func(); + test_case->func(0); set_cn_logging_level(CN_LOGGING_NONE); + printf("\n\n"); break; case CN_TEST_GEN_FAIL: printf("FAILED TO GENERATE VALID INPUT\n"); @@ -225,7 +225,7 @@ int cn_test_main(int argc, char* argv[]) { set_cn_logging_level(CN_LOGGING_INFO); reset_cn_exit_cb(); // raise(SIGTRAP); // Trigger breakpoint - test_cases[mapToCase[testcase - 1]].func(); + test_cases[mapToCase[testcase - 1]].func(0); } return !(failed == 0 && errored == 0); From c0ba84670fdf310633503ff5d78ea04d1cbbc378 Mon Sep 17 00:00:00 2001 From: Rini Banerjee <26858592+rbanerjee20@users.noreply.github.com> Date: Thu, 31 Oct 2024 17:12:21 +0000 Subject: [PATCH 006/148] [CN-exec/CN-test-gen] Further records fix (#680) --- backend/cn/lib/cn_internal_to_ail.ml | 4 +- backend/cn/lib/cn_internal_to_ail.mli | 2 +- backend/cn/lib/executable_spec.ml | 23 ++--- backend/cn/lib/executable_spec_internal.ml | 72 -------------- backend/cn/lib/executable_spec_records.ml | 109 ++++++++++++++++++--- 5 files changed, 107 insertions(+), 103 deletions(-) diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 683db6226..0942dba95 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -1616,9 +1616,9 @@ let generate_struct_definition ?(lc = true) (constructor, members) = (constr_sym, (Cerb_location.unknown, empty_attributes, generate_tag_definition members)) -let cn_to_ail_pred_records map_bindings = +let cn_to_ail_records map_bindings = let flipped_bindings = List.map (fun (ms, sym) -> (sym, ms)) map_bindings in - List.map generate_struct_definition flipped_bindings + List.map (generate_struct_definition ~lc:false) flipped_bindings (* Generic map get for structs, datatypes and records *) diff --git a/backend/cn/lib/cn_internal_to_ail.mli b/backend/cn/lib/cn_internal_to_ail.mli index 841db0085..29587da35 100644 --- a/backend/cn/lib/cn_internal_to_ail.mli +++ b/backend/cn/lib/cn_internal_to_ail.mli @@ -143,7 +143,7 @@ val cn_to_ail_datatype A.sigma_cn_datatype -> Locations.t * A.sigma_tag_definition list -val cn_to_ail_pred_records +val cn_to_ail_records : (MembersKey.t * A.ail_identifier) list -> A.sigma_tag_definition list diff --git a/backend/cn/lib/executable_spec.ml b/backend/cn/lib/executable_spec.ml index e98964401..0c731a3f9 100644 --- a/backend/cn/lib/executable_spec.ml +++ b/backend/cn/lib/executable_spec.ml @@ -227,10 +227,10 @@ let main let c_datatype_defs, _c_datatype_decls, c_datatype_equality_fun_decls = generate_c_datatypes sigm in - let c_function_defs, c_function_decls, locs_and_c_extern_function_decls, c_records = + let c_function_defs, c_function_decls, locs_and_c_extern_function_decls, _c_records = generate_c_functions_internal sigm prog5.logical_predicates in - let c_predicate_defs, locs_and_c_predicate_decls, c_records' = + let c_predicate_defs, locs_and_c_predicate_decls, _c_records' = generate_c_predicates_internal sigm prog5.resource_predicates in let conversion_function_defs, conversion_function_decls = @@ -252,31 +252,22 @@ let main let cn_converted_struct_defs, _cn_converted_struct_decls = generate_cn_versions_of_structs sigm.tag_definitions in - (* let (records_str, record_equality_fun_strs, record_equality_fun_prot_strs) = - generate_all_record_strs sigm in *) - let record_defs_str, _record_decls_str = c_records in - let record_defs_str', _record_decls_str = c_records' in let record_fun_defs, record_fun_decls = - Executable_spec_internal.generate_c_record_funs - sigm - prog5.logical_predicates - prog5.resource_predicates + Executable_spec_records.generate_c_record_funs sigm in - (* let extern_ownership_globals = if with_ownership_checking then "\n" ^ - generate_ownership_globals ~is_extern:true () else "" in *) let datatype_strs = String.concat "\n" (List.map snd c_datatype_defs) in let predicate_decls = String.concat "\n" (List.concat (List.map snd locs_and_c_predicate_decls)) in + let record_defs, _record_decls = Executable_spec_records.generate_all_record_strs () in let cn_header_decls_list = [ cn_utils_header; "\n"; + (if not (String.equal record_defs "") then "\n/* CN RECORDS */\n\n" else ""); + record_defs; c_struct_defs; cn_converted_struct_defs; - (if String.equal record_defs_str "" then "\n/* CN RECORDS */\n\n" else ""); - record_defs_str; - record_defs_str'; - (if String.equal datatype_strs "" then "\n/* CN DATATYPES */\n\n" else ""); + (if not (String.equal datatype_strs "") then "\n/* CN DATATYPES */\n\n" else ""); datatype_strs; "\n\n/* OWNERSHIP FUNCTIONS */\n\n"; ownership_function_decls; diff --git a/backend/cn/lib/executable_spec_internal.ml b/backend/cn/lib/executable_spec_internal.ml index 8cbc53a0b..9d8670bbc 100644 --- a/backend/cn/lib/executable_spec_internal.ml +++ b/backend/cn/lib/executable_spec_internal.ml @@ -235,13 +235,6 @@ let generate_record_strs (record_def_strs, record_decl_strs) -let generate_all_record_strs sigm = - generate_record_strs - sigm - (Cn_internal_to_ail.cn_to_ail_pred_records - (Cn_internal_to_ail.RecordMap.bindings !Cn_internal_to_ail.records)) - - let generate_str_from_ail_struct ail_struct = CF.Pp_utils.to_plain_pretty_string (generate_doc_from_ail_struct ail_struct) @@ -375,71 +368,6 @@ let fns_and_preds_with_record_rt (funs, preds) = (fun_syms, pred_syms) -let generate_c_record_funs - (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) - (logical_predicates : (Sym.t * LogicalFunctions.definition) list) - (resource_predicates : (Sym.t * ResourcePredicates.definition) list) - = - let cn_record_info = - List.map - (fun (sym, (def : LogicalFunctions.definition)) -> - match def.return_bt with - | BT.Record ms -> - [ (Cn_internal_to_ail.generate_sym_with_suffix ~suffix:"_record" sym, ms) ] - | _ -> []) - logical_predicates - in - let cn_record_info' = - List.map - (fun (sym, (def : ResourcePredicates.definition)) -> - match def.oarg_bt with - | BT.Record ms -> - [ (Cn_internal_to_ail.generate_sym_with_suffix ~suffix:"_record" sym, ms) ] - | _ -> []) - resource_predicates - in - let cn_record_info = List.concat (cn_record_info @ cn_record_info') in - let record_equality_functions = - List.concat - (List.map - (Cn_internal_to_ail.generate_record_equality_function sigm.cn_datatypes) - cn_record_info) - in - let record_default_functions = - List.concat - (List.map - (Cn_internal_to_ail.generate_record_default_function sigm.cn_datatypes) - cn_record_info) - in - let record_map_get_functions = - List.concat (List.map Cn_internal_to_ail.generate_record_map_get cn_record_info) - in - let eq_decls, eq_defs = List.split record_equality_functions in - let default_decls, default_defs = List.split record_default_functions in - let mapget_decls, mapget_defs = List.split record_map_get_functions in - let modified_prog1 : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma = - { sigm with - declarations = eq_decls @ default_decls @ mapget_decls; - function_definitions = eq_defs @ default_defs @ mapget_defs - } - in - let fun_doc = - CF.Pp_ail.pp_program ~executable_spec:true ~show_include:true (None, modified_prog1) - in - let fun_strs = CF.Pp_utils.to_plain_pretty_string fun_doc in - let decl_docs = - List.map - (fun (sym, (_, _, decl)) -> - CF.Pp_ail.pp_function_prototype ~executable_spec:true sym decl) - (eq_decls @ default_decls @ mapget_decls) - in - let fun_prot_strs = - List.map (fun doc -> [ CF.Pp_utils.to_plain_pretty_string doc ]) decl_docs - in - let fun_prot_strs = String.concat "\n" (List.concat fun_prot_strs) in - (fun_strs, fun_prot_strs) - - let generate_c_functions_internal (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) (logical_predicates : (Sym.t * LogicalFunctions.definition) list) diff --git a/backend/cn/lib/executable_spec_records.ml b/backend/cn/lib/executable_spec_records.ml index 11f571e33..ce97ff338 100644 --- a/backend/cn/lib/executable_spec_records.ml +++ b/backend/cn/lib/executable_spec_records.ml @@ -118,33 +118,118 @@ let add_records_to_map_from_instrumentation (i : Core_to_mucore.instrumentation) match i.internal with Some instr -> aux_at instr | None -> () -let add_records_to_map_from_fns_and_preds (prog5 : unit Mucore.file) = - let populate cn_sym bt = - Cn_internal_to_ail.augment_record_map ~cn_sym bt; - match bt with - | BT.Record members -> - List.iter Cn_internal_to_ail.augment_record_map (List.map snd members) - | _ -> () - in +let rec populate ?cn_sym bt = + match bt with + | BT.Record members -> + (match cn_sym with + (* Naming convention only needed for top-level records returned from CN functions and predicates *) + | Some cn_sym' -> Cn_internal_to_ail.augment_record_map ~cn_sym:cn_sym' bt + | None -> Cn_internal_to_ail.augment_record_map bt); + List.iter (fun bt' -> populate bt') (List.map snd members) + | _ -> () + + +let add_records_to_map_from_fns_and_preds cn_funs cn_preds = let fun_syms_and_ret_types = List.map (fun (sym, (def : LogicalFunctions.definition)) -> (sym, def.return_bt)) - prog5.logical_predicates + cn_funs in let pred_syms_and_ret_types = List.map (fun (sym, (def : ResourcePredicates.definition)) -> (sym, def.oarg_bt)) - prog5.resource_predicates + cn_preds in List.iter - (fun (cn_sym, bt) -> populate cn_sym bt) + (fun (cn_sym, bt) -> populate ~cn_sym bt) (fun_syms_and_ret_types @ pred_syms_and_ret_types) +let add_records_to_map_from_datatype (dt : Mucore.datatype) = + let bts = List.map (fun (_, ms) -> List.map snd ms) dt.cases in + let bts = List.concat bts in + List.iter populate bts + + +let add_records_to_map_from_struct (tag_def : Mucore.tag_definition) = + match tag_def with + | Mucore.StructDef sl -> + List.iter + (fun (sp : Memory.struct_piece) -> + match sp.member_or_padding with + | Some (_, sct) -> + populate + (BT.of_sct Memory.is_signed_integer_type Memory.size_of_integer_type sct) + | None -> ()) + sl + | UnionDef -> () + + (* Populate record table *) let populate_record_map (instrumentation : Core_to_mucore.instrumentation list) (prog5 : unit Mucore.file) = - add_records_to_map_from_fns_and_preds prog5; + add_records_to_map_from_fns_and_preds prog5.logical_predicates prog5.resource_predicates; + List.iter add_records_to_map_from_datatype (List.map snd prog5.datatypes); + List.iter + add_records_to_map_from_struct + (List.map snd (Pmap.bindings_list prog5.tagDefs)); List.iter add_records_to_map_from_instrumentation instrumentation + + +let generate_all_record_strs () = + let ail_records = + Cn_internal_to_ail.cn_to_ail_records + (Cn_internal_to_ail.RecordMap.bindings !Cn_internal_to_ail.records) + in + let record_def_strs, record_decl_strs = + Executable_spec_internal.generate_c_records ail_records + in + (record_def_strs, record_decl_strs) + + +let generate_c_record_funs (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) = + let cn_record_info = + Cn_internal_to_ail.RecordMap.bindings !Cn_internal_to_ail.records + in + let cn_record_info = List.map (fun (ms, sym) -> (sym, ms)) cn_record_info in + let record_equality_functions = + List.concat + (List.map + (Cn_internal_to_ail.generate_record_equality_function sigm.cn_datatypes) + cn_record_info) + in + let record_default_functions = + List.concat + (List.map + (Cn_internal_to_ail.generate_record_default_function sigm.cn_datatypes) + cn_record_info) + in + let record_map_get_functions = + List.concat (List.map Cn_internal_to_ail.generate_record_map_get cn_record_info) + in + let eq_decls, eq_defs = List.split record_equality_functions in + let default_decls, default_defs = List.split record_default_functions in + let mapget_decls, mapget_defs = List.split record_map_get_functions in + let modified_prog1 : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma = + { sigm with + declarations = eq_decls @ default_decls @ mapget_decls; + function_definitions = eq_defs @ default_defs @ mapget_defs + } + in + let fun_doc = + CF.Pp_ail.pp_program ~executable_spec:true ~show_include:true (None, modified_prog1) + in + let fun_strs = CF.Pp_utils.to_plain_pretty_string fun_doc in + let decl_docs = + List.map + (fun (sym, (_, _, decl)) -> + CF.Pp_ail.pp_function_prototype ~executable_spec:true sym decl) + (eq_decls @ default_decls @ mapget_decls) + in + let fun_prot_strs = + List.map (fun doc -> [ CF.Pp_utils.to_plain_pretty_string doc ]) decl_docs + in + let fun_prot_strs = String.concat "\n" (List.concat fun_prot_strs) in + (fun_strs, fun_prot_strs) From 573f9ab34753b1d7344255d274a0f6b2b0b5870c Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Thu, 31 Oct 2024 15:56:34 +0000 Subject: [PATCH 007/148] Solver parameters for simple-smt interface + CVC5 logic parameter --- backend/cn/lib/simple_smt.ml | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/backend/cn/lib/simple_smt.ml b/backend/cn/lib/simple_smt.ml index b62e13b6a..763dca4aa 100644 --- a/backend/cn/lib/simple_smt.ml +++ b/backend/cn/lib/simple_smt.ml @@ -489,6 +489,8 @@ type solver_log = type solver_config = { exe : string; opts : string list; + params : (string * string) list; + (* (parameter name * setting) list, the name without leading colon *) exts : solver_extensions; log : solver_log } @@ -811,6 +813,9 @@ let new_solver (cfg : solver_config) : solver = in ack_command s (set_option ":print-success" "true"); ack_command s (set_option ":produce-models" "true"); + List.iter + (fun (name, setting) -> ack_command s (set_option (":" ^ name) setting)) + cfg.params; Gc.finalise (fun me -> me.stop ()) s; s @@ -885,8 +890,15 @@ let printf_log = let cvc5 : solver_config = - { exe = "cvc5"; opts = [ "--incremental"; "--sets-ext" ]; exts = CVC5; log = quiet_log } + { exe = "cvc5"; + opts = [ "--incremental"; "--sets-ext"; "--force-logic=QF_AUFBVDTLIA" ]; + params = []; + exts = CVC5; + log = quiet_log + } let z3 : solver_config = - { exe = "z3"; opts = [ "-in"; "-smt2" ]; exts = Z3; log = quiet_log } + (* let params = [ ("sat.smt", "true") ] in *) + let params = [] in + { exe = "z3"; opts = [ "-in"; "-smt2" ]; params; exts = Z3; log = quiet_log } From cb59817a80cf7d856340c2ee51800d8470984d36 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Thu, 31 Oct 2024 16:55:28 +0000 Subject: [PATCH 008/148] bump CVC5 version to 1.2.0 in the CI --- .github/workflows/ci-bench.yml | 2 +- .github/workflows/ci-pr-bench.yml.disabled | 2 +- .github/workflows/ci.yml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci-bench.yml b/.github/workflows/ci-bench.yml index 557390545..8821aa22a 100644 --- a/.github/workflows/ci-bench.yml +++ b/.github/workflows/ci-bench.yml @@ -78,7 +78,7 @@ jobs: uses: robinraju/release-downloader@v1 with: repository: cvc5/cvc5 - tag: cvc5-1.1.2 + tag: cvc5-1.2.0 fileName: cvc5-Linux-static.zip - name: Unzip and install cvc5 diff --git a/.github/workflows/ci-pr-bench.yml.disabled b/.github/workflows/ci-pr-bench.yml.disabled index aef43678c..e2c5b01cd 100644 --- a/.github/workflows/ci-pr-bench.yml.disabled +++ b/.github/workflows/ci-pr-bench.yml.disabled @@ -83,7 +83,7 @@ jobs: uses: robinraju/release-downloader@v1 with: repository: cvc5/cvc5 - tag: cvc5-1.1.2 + tag: cvc5-1.2.0 fileName: cvc5-Linux-static.zip - name: Unzip and install cvc5 diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 1af812990..47c2756dc 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -80,7 +80,7 @@ jobs: uses: robinraju/release-downloader@v1 with: repository: cvc5/cvc5 - tag: cvc5-1.1.2 + tag: cvc5-1.2.0 fileName: cvc5-Linux-static.zip - name: Unzip and install cvc5 From 36523fc98176d27756f459a3f2f077296547de70 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Thu, 31 Oct 2024 17:02:01 +0000 Subject: [PATCH 009/148] fix CVC5 filepath --- .github/workflows/ci-bench.yml | 2 +- .github/workflows/ci-pr-bench.yml.disabled | 2 +- .github/workflows/ci.yml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci-bench.yml b/.github/workflows/ci-bench.yml index 8821aa22a..197e7c47d 100644 --- a/.github/workflows/ci-bench.yml +++ b/.github/workflows/ci-bench.yml @@ -79,7 +79,7 @@ jobs: with: repository: cvc5/cvc5 tag: cvc5-1.2.0 - fileName: cvc5-Linux-static.zip + fileName: cvc5-Linux-x86_64-static.zip - name: Unzip and install cvc5 run: | diff --git a/.github/workflows/ci-pr-bench.yml.disabled b/.github/workflows/ci-pr-bench.yml.disabled index e2c5b01cd..7b66b86e2 100644 --- a/.github/workflows/ci-pr-bench.yml.disabled +++ b/.github/workflows/ci-pr-bench.yml.disabled @@ -84,7 +84,7 @@ jobs: with: repository: cvc5/cvc5 tag: cvc5-1.2.0 - fileName: cvc5-Linux-static.zip + fileName: cvc5-Linux-x86_64-static.zip - name: Unzip and install cvc5 run: | diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 47c2756dc..e08130d76 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -81,7 +81,7 @@ jobs: with: repository: cvc5/cvc5 tag: cvc5-1.2.0 - fileName: cvc5-Linux-static.zip + fileName: cvc5-Linux-x86_64-static.zip - name: Unzip and install cvc5 run: | From 789d1d077331ca42baeb68ab042d39da2c9b4c9a Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Thu, 31 Oct 2024 17:19:31 +0000 Subject: [PATCH 010/148] fixes --- .github/workflows/ci-bench.yml | 2 +- .github/workflows/ci-pr-bench.yml.disabled | 2 +- .github/workflows/ci.yml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci-bench.yml b/.github/workflows/ci-bench.yml index 197e7c47d..9c0e92d76 100644 --- a/.github/workflows/ci-bench.yml +++ b/.github/workflows/ci-bench.yml @@ -83,7 +83,7 @@ jobs: - name: Unzip and install cvc5 run: | - unzip cvc5-Linux-static.zip + unzip cvc5-Linux-x86_64-static.zip chmod +x cvc5-Linux-static/bin/cvc5 sudo cp cvc5-Linux-static/bin/cvc5 /usr/local/bin/ diff --git a/.github/workflows/ci-pr-bench.yml.disabled b/.github/workflows/ci-pr-bench.yml.disabled index 7b66b86e2..1b4dd50f7 100644 --- a/.github/workflows/ci-pr-bench.yml.disabled +++ b/.github/workflows/ci-pr-bench.yml.disabled @@ -88,7 +88,7 @@ jobs: - name: Unzip and install cvc5 run: | - unzip cvc5-Linux-static.zip + unzip cvc5-Linux-x86_64-static.zip chmod +x cvc5-Linux-static/bin/cvc5 sudo cp cvc5-Linux-static/bin/cvc5 /usr/local/bin/ diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index e08130d76..901e337e6 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -85,7 +85,7 @@ jobs: - name: Unzip and install cvc5 run: | - unzip cvc5-Linux-static.zip + unzip cvc5-Linux-x86_64-static.zip chmod +x cvc5-Linux-static/bin/cvc5 sudo cp cvc5-Linux-static/bin/cvc5 /usr/local/bin/ From 16d319bc3ed1a8dc07a2949b604ca407b61d4f0c Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Thu, 31 Oct 2024 17:26:14 +0000 Subject: [PATCH 011/148] more fixes --- .github/workflows/ci-bench.yml | 4 ++-- .github/workflows/ci-pr-bench.yml.disabled | 4 ++-- .github/workflows/ci.yml | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/.github/workflows/ci-bench.yml b/.github/workflows/ci-bench.yml index 9c0e92d76..101931c54 100644 --- a/.github/workflows/ci-bench.yml +++ b/.github/workflows/ci-bench.yml @@ -84,8 +84,8 @@ jobs: - name: Unzip and install cvc5 run: | unzip cvc5-Linux-x86_64-static.zip - chmod +x cvc5-Linux-static/bin/cvc5 - sudo cp cvc5-Linux-static/bin/cvc5 /usr/local/bin/ + chmod +x cvc5-Linux-x86_64-static/bin/cvc5 + sudo cp cvc5-Linux-x86_64-static/bin/cvc5 /usr/local/bin/ - name: Install CN run: | diff --git a/.github/workflows/ci-pr-bench.yml.disabled b/.github/workflows/ci-pr-bench.yml.disabled index 1b4dd50f7..921c7d774 100644 --- a/.github/workflows/ci-pr-bench.yml.disabled +++ b/.github/workflows/ci-pr-bench.yml.disabled @@ -89,8 +89,8 @@ jobs: - name: Unzip and install cvc5 run: | unzip cvc5-Linux-x86_64-static.zip - chmod +x cvc5-Linux-static/bin/cvc5 - sudo cp cvc5-Linux-static/bin/cvc5 /usr/local/bin/ + chmod +x cvc5-Linux-x86_64-static/bin/cvc5 + sudo cp cvc5-Linux-x86_64-static/bin/cvc5 /usr/local/bin/ - name: Install CN run: | diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 901e337e6..bc25e9fa7 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -86,8 +86,8 @@ jobs: - name: Unzip and install cvc5 run: | unzip cvc5-Linux-x86_64-static.zip - chmod +x cvc5-Linux-static/bin/cvc5 - sudo cp cvc5-Linux-static/bin/cvc5 /usr/local/bin/ + chmod +x cvc5-Linux-x86_64-static/bin/cvc5 + sudo cp cvc5-Linux-x86_64-static/bin/cvc5 /usr/local/bin/ - name: Install CN run: | From 0ef1e7075079a5befb4d02e8a156e9ad8fcd76c0 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Thu, 31 Oct 2024 18:03:59 +0000 Subject: [PATCH 012/148] tentatively set CVC5 logic as QF_ALL, because the previous setting leads to a timeout in 00003.point.c --- backend/cn/lib/simple_smt.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/backend/cn/lib/simple_smt.ml b/backend/cn/lib/simple_smt.ml index 763dca4aa..50572d1db 100644 --- a/backend/cn/lib/simple_smt.ml +++ b/backend/cn/lib/simple_smt.ml @@ -891,7 +891,8 @@ let printf_log = let cvc5 : solver_config = { exe = "cvc5"; - opts = [ "--incremental"; "--sets-ext"; "--force-logic=QF_AUFBVDTLIA" ]; + (* opts = [ "--incremental"; "--sets-ext"; "--force-logic=QF_AUFBVDTLIA" ]; *) + opts = [ "--incremental"; "--sets-ext"; "--force-logic=QF_ALL" ]; params = []; exts = CVC5; log = quiet_log From efc7cdbd28bcb63f4d8b9b0da72f701a1e985f2d Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Fri, 1 Nov 2024 11:55:03 +0000 Subject: [PATCH 013/148] CN: Update opam file --- cn.opam | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/cn.opam b/cn.opam index 110108787..cd8248942 100644 --- a/cn.opam +++ b/cn.opam @@ -2,6 +2,16 @@ opam-version: "2.0" synopsis: "The CN type system" description: "The CN type system" maintainer: ["Christopher Pulte "] +authors: [ + "Christopher Pulte" + "Thomas Sewell" + "Dhruv Makwana" + "Rini Banerjee" + "Zain Amer" + "Kayvan Memarian" +] +homepage: "https://rems-project.github.io/cn-tutorial" +bug-reports: "https://github.com/rems-project/cerberus/issues" depends: [ "cerberus-lib" "monomorphic" @@ -9,6 +19,7 @@ depends: [ "ppx_deriving" "cmdliner" "ocamlgraph" + "zarith" {>= "1.13"} ] build: [ ["dune" "subst"] {pinned} From 8788faf489cd34fa145978ee8e67b7795f1ba9f7 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Fri, 1 Nov 2024 14:22:33 -0400 Subject: [PATCH 014/148] Update cn.opam --- cn.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cn.opam b/cn.opam index cd8248942..840cb17de 100644 --- a/cn.opam +++ b/cn.opam @@ -7,7 +7,7 @@ authors: [ "Thomas Sewell" "Dhruv Makwana" "Rini Banerjee" - "Zain Amer" + "Zain K Aamer" "Kayvan Memarian" ] homepage: "https://rems-project.github.io/cn-tutorial" From 23700335056f615efb1d24d489e8e1ce388b54b3 Mon Sep 17 00:00:00 2001 From: Sam Cowger Date: Thu, 31 Oct 2024 09:25:38 -0700 Subject: [PATCH 015/148] CN: allow {de,}serializing reports to/from JSON --- backend/cn/lib/dune | 7 ++++-- backend/cn/lib/pp.ml | 14 ++++++++++++ backend/cn/lib/pp.mli | 4 ++++ backend/cn/lib/report.ml | 48 +++++++++++++++++++++++++++++++++++++-- backend/cn/lib/report.mli | 4 ++++ cn.opam | 1 + 6 files changed, 74 insertions(+), 4 deletions(-) diff --git a/backend/cn/lib/dune b/backend/cn/lib/dune index d84bd0072..b82d2f8e3 100644 --- a/backend/cn/lib/dune +++ b/backend/cn/lib/dune @@ -13,13 +13,16 @@ menhirLib monomorphic ocamlgraph + ppx_deriving_yojson.runtime result str - unix) + unix + yojson) (preprocess (pps ppx_deriving.eq ppx_deriving.fold ppx_deriving.map ppx_deriving.ord - ppx_deriving.show))) + ppx_deriving.show + ppx_deriving_yojson))) diff --git a/backend/cn/lib/pp.ml b/backend/cn/lib/pp.ml index 94836734c..787d533e4 100644 --- a/backend/cn/lib/pp.ml +++ b/backend/cn/lib/pp.ml @@ -335,3 +335,17 @@ let progress_simple title name = let of_total cur total = Printf.sprintf "[%d/%d]" cur total + +let document_to_yojson (doc : document) : Yojson.Safe.t = + let buf_size = 1024 (* chosen pretty arbitrarily *) in + let buf = Stdlib.Buffer.create buf_size in + PPrint.ToBuffer.compact buf doc; + let str = Stdlib.Buffer.contents buf in + `String str + + +let document_of_yojson (json : Yojson.Safe.t) : (document, string) Result.t = + match json with + | `String str -> Ok (PPrint.arbitrary_string str) + | _ -> + Error ("document_of_yojson: expected `String, found " ^ Yojson.Safe.to_string json) diff --git a/backend/cn/lib/pp.mli b/backend/cn/lib/pp.mli index 7bb43e9a4..cebf6bab8 100644 --- a/backend/cn/lib/pp.mli +++ b/backend/cn/lib/pp.mli @@ -347,3 +347,7 @@ val print_json : Yojson.Safe.t Lazy.t -> unit val progress_simple : string -> string -> unit val of_total : int -> int -> string + +val document_to_yojson : document -> Yojson.Safe.t + +val document_of_yojson : Yojson.Safe.t -> (document, string) Result.t diff --git a/backend/cn/lib/report.ml b/backend/cn/lib/report.ml index a41210634..a4d23d42a 100644 --- a/backend/cn/lib/report.ml +++ b/backend/cn/lib/report.ml @@ -2,11 +2,13 @@ type term_entry = { term : Pp.document; value : Pp.document } +[@@deriving yojson] type predicate_clause_entry = { cond : Pp.document; clause : Pp.document } +[@@deriving yojson] type resource_entry = { res : Pp.document; @@ -19,12 +21,14 @@ type where_report = loc_cartesian : ((int * int) * (int * int)) option; loc_head : string (* loc_pos: string; *) } +[@@deriving yojson] (* Different forms of a document. *) type simp_view = { original : Pp.document; (* original view *) simplified : Pp.document list (* simplified based on model *) } +[@@deriving yojson] type label = string @@ -32,11 +36,49 @@ let lab_interesting : label = "interesting" let lab_uninteresting : label = "uninteresting" -module StrMap = Map.Make (String) +let sequence (xs : ('a, 'e) Result.t list) : ('a list, 'e) Result.t = + let ( let* ) = Result.bind in + let rcons e es = + let* v = e in + let* vs = es in + Ok (v :: vs) + in + List.fold_right rcons xs (Ok []) + + +module StrMap = struct + module M = Map.Make (String) + + let to_yojson (value_to_yojson : 'v -> Yojson.Safe.t) (map : 'v M.t) : Yojson.Safe.t = + `Assoc (List.map_snd value_to_yojson (M.bindings map)) + + + let of_yojson + (value_of_yojson : Yojson.Safe.t -> ('v, string) Result.t) + (json : Yojson.Safe.t) + : ('v M.t, string) Result.t + = + match json with + | `Assoc elems -> + let ( let* ) = Result.bind in + let elems' = + List.map + (fun (key, json_value) -> + let* value = value_of_yojson json_value in + Ok (key, value)) + elems + in + let* bindings = sequence elems' in + Ok (M.of_seq (List.to_seq bindings)) + | _ -> Error ("StrMap.of_yojson: expected `Assoc, found " ^ Yojson.Safe.to_string json) + + + include M +end (* Things classified in various ways. To start we just have "interesting" and "uninteresting", but we could add more *) -type 'a labeled_view = 'a list StrMap.t +type 'a labeled_view = 'a list StrMap.t [@@deriving yojson] let labeled_empty = StrMap.empty @@ -49,6 +91,7 @@ type state_report = constraints : simp_view labeled_view; terms : term_entry labeled_view } +[@@deriving yojson] type report = { trace : state_report list; @@ -56,6 +99,7 @@ type report = unproven : Pp.document (* * Pp.document *) option; predicate_hints : predicate_clause_entry list } +[@@deriving yojson] let list elements = String.concat "" elements diff --git a/backend/cn/lib/report.mli b/backend/cn/lib/report.mli index 98d691da2..63ca65295 100644 --- a/backend/cn/lib/report.mli +++ b/backend/cn/lib/report.mli @@ -77,3 +77,7 @@ type report = The third argument is information about the various things that need to be saved. *) val make : string -> string Option.m -> report -> string + +val report_of_yojson : Yojson.Safe.t -> (report, string) Result.t + +val report_to_yojson : report -> Yojson.Safe.t diff --git a/cn.opam b/cn.opam index 840cb17de..65b39174e 100644 --- a/cn.opam +++ b/cn.opam @@ -17,6 +17,7 @@ depends: [ "monomorphic" "ocaml" {>= "4.14.0"} "ppx_deriving" + "ppx_deriving_yojson" {>= "3.8.0"} "cmdliner" "ocamlgraph" "zarith" {>= "1.13"} From fab7171b650364a8bc7e2135970a596eb0f02aa7 Mon Sep 17 00:00:00 2001 From: Sam Cowger Date: Thu, 31 Oct 2024 09:38:49 -0700 Subject: [PATCH 016/148] CN: serialize reports to JSON on error --- backend/cn/lib/typeErrors.ml | 82 ++++++++++++++++++++++++------------ 1 file changed, 56 insertions(+), 26 deletions(-) diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index aec11c3a9..5406616e1 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -616,30 +616,33 @@ let canonicalize (path : string) : string = path -(** Create a filename derived from the given error location, and create a file - with that name in [output_dir], which will be created if it doesn't exist. - If no directory is provided, or if the provided directory name is - unusable, the file is created in the system temporary directory instead. *) +(** Construct a canonical path to a directory and create the directory if it + doesn't already exist. If [output_dir] is provided, the path will point to + it. If not, the path will point to a temporary directory instead. *) +let mk_output_dir (output_dir : string option) : string = + match output_dir with + | None -> Filename.get_temp_dir_name () + | Some d -> + let dir = canonicalize d in + if not (Sys.file_exists dir) then ( + (* 0o700 == r+w+x permissions for current user *) + Sys.mkdir dir 0o700; + dir) + else if Sys.is_directory dir then + dir + else + Filename.get_temp_dir_name () + + +(** Construct a canonical filename for state output derived from the given error + location, located in [output_dir], if possible. *) let mk_state_file_name ?(output_dir : string option) ?(fn_name : string option) (loc : Cerb_location.t) : string = - let dir = - match output_dir with - | None -> Filename.get_temp_dir_name () - | Some d -> - let dir = canonicalize d in - if not (Sys.file_exists dir) then ( - (* 0o700 == r+w+x permissions for current user *) - Sys.mkdir dir 0o700; - dir) - else if Sys.is_directory dir then - dir - else - Filename.get_temp_dir_name () - in + let dir = mk_output_dir output_dir in let file_tag = match Cerb_location.get_filename loc with | None -> "" @@ -650,6 +653,25 @@ let mk_state_file_name Filename.concat dir filename +(** Construct a canonical filename for report output derived from the given + error location, located in [output_dir], if possible. *) +let mk_report_file_name + ?(output_dir : string option) + ?(fn_name : string option) + (loc : Cerb_location.t) + : string + = + let dir = mk_output_dir output_dir in + let file_tag = + match Cerb_location.get_filename loc with + | None -> "" + | Some filename -> "__" ^ Filename.basename filename + in + let function_tag = match fn_name with None -> "" | Some fn -> "__" ^ fn in + let filename = "report" ^ file_tag ^ function_tag ^ ".json" in + Filename.concat dir filename + + (** Format the error for human readability and print it to [stderr]. if the error contains enough information to create an HTML state report, generate one in [output_dir] (or, failing that, the system temporary directory) and @@ -662,23 +684,30 @@ let report_pretty ?output_dir:dir_ ?(fn_name : string option) { loc; msg } = | Some state -> let file = mk_state_file_name ?output_dir:dir_ ?fn_name loc in let link = Report.make file (Cerb_location.get_filename loc) state in - let msg = !^"State file:" ^^^ !^("file://" ^ link) in - Some msg - | None -> None + let state_msg = !^"State file:" ^^^ !^("file://" ^ link) in + let report_file = mk_report_file_name ?output_dir:dir_ ?fn_name loc in + let report_js = Report.report_to_yojson state in + let () = Yojson.Safe.to_file report_file report_js in + let report_msg = !^"Report file:" ^^^ !^("file://" ^ report_file) in + [ state_msg; report_msg ] + | None -> [] in - Pp.error loc report.short (Option.to_list report.descr @ Option.to_list consider) + Pp.error loc report.short (Option.to_list report.descr @ consider) (* stealing some logic from pp_errors *) let report_json ?output_dir:dir_ ?(fn_name : string option) { loc; msg } = let report = pp_message msg in - let state_error_file = + let state_error_file, report_file = match report.state with | Some state -> let file = mk_state_file_name ?output_dir:dir_ ?fn_name loc in let link = Report.make file (Cerb_location.get_filename loc) state in - `String link - | None -> `Null + let report_file = mk_report_file_name ?output_dir:dir_ ?fn_name loc in + let report_js = Report.report_to_yojson state in + let () = Yojson.Safe.to_file report_file report_js in + (`String link, `String report_file) + | None -> (`Null, `Null) in let descr = match report.descr with None -> `Null | Some descr -> `String (Pp.plain descr) @@ -688,7 +717,8 @@ let report_json ?output_dir:dir_ ?(fn_name : string option) { loc; msg } = [ ("loc", Loc.json_loc loc); ("short", `String (Pp.plain report.short)); ("descr", descr); - ("state", state_error_file) + ("state", state_error_file); + ("report", report_file) ] in Yojson.Safe.to_channel ~std:true stderr json From 6af0f3cfecb72ee9da5ae4f14550b19347e525d8 Mon Sep 17 00:00:00 2001 From: Sam Cowger Date: Thu, 31 Oct 2024 10:02:24 -0700 Subject: [PATCH 017/148] CN: only serialize JSON state files on request --- backend/cn/bin/main.ml | 41 ++++++++++++++++++++++++++++-------- backend/cn/lib/typeErrors.ml | 38 +++++++++++++++++++++++---------- 2 files changed, 59 insertions(+), 20 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index d9f620101..6e032d726 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -194,13 +194,14 @@ let report_type_error ~(json : bool) ?(output_dir : string option) ?(fn_name : string option) + ?(serialize_json : bool = false) (error : TypeErrors.t) : unit = if json then - TypeErrors.report_json ?output_dir ?fn_name error + TypeErrors.report_json ?output_dir ?fn_name ~serialize_json error else - TypeErrors.report_pretty ?output_dir ?fn_name error + TypeErrors.report_pretty ?output_dir ?fn_name ~serialize_json error (** Generate an appropriate exit code for the provided error. *) @@ -222,8 +223,13 @@ let exit_code_of_errors (errors : TypeErrors.t list) : int option = (** Report the provided error, then exit. *) -let handle_type_error ~(json : bool) ?(output_dir : string option) (error : TypeErrors.t) = - report_type_error ~json ?output_dir error; +let handle_type_error + ~(json : bool) + ?(output_dir : string option) + ?(serialize_json : bool = false) + (error : TypeErrors.t) + = + report_type_error ~json ?output_dir ~serialize_json error; exit (exit_code_of_error error) @@ -233,6 +239,7 @@ let well_formed incl_dirs incl_files json + json_trace output_dir csv_times log_times @@ -252,7 +259,7 @@ let well_formed ~use_peval ~no_inherit_loc ~magic_comment_char_dollar - ~handle_error:(handle_type_error ~json ?output_dir) + ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) ~f:(fun ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused:_ -> Resultat.return ()) @@ -269,6 +276,7 @@ let verify slow_smt_dir no_timestamps json + json_trace output_dir diag lemmata @@ -327,14 +335,20 @@ let verify ~use_peval ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) - ~handle_error:(handle_type_error ~json ?output_dir) + ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) ~f:(fun ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused -> let check (functions, lemmas) = let open Typing in let@ errors = Check.time_check_c_functions functions in if not quiet then List.iter - (fun (fn, err) -> report_type_error ~json ?output_dir ~fn_name:fn err) + (fun (fn, err) -> + report_type_error + ~json + ?output_dir + ~fn_name:fn + ~serialize_json:json_trace + err) errors; Option.fold ~none:() ~some:exit (exit_code_of_errors (List.map snd errors)); Check.generate_lemmas lemmas lemmata @@ -353,6 +367,7 @@ let generate_executable_specs print_sym_nums no_timestamps json + json_trace output_dir diag only @@ -401,7 +416,7 @@ let generate_executable_specs ~use_peval ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) - ~handle_error:(handle_type_error ~json ?output_dir) + ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) ~f:(fun ~prog5 ~ail_prog ~statement_locs ~paused:_ -> Cerb_colour.without_colour (fun () -> @@ -726,10 +741,15 @@ module Verify_flags = struct let json = - let doc = "output in json format" in + let doc = "output summary in JSON format" in Arg.(value & flag & info [ "json" ] ~doc) + let json_trace = + let doc = "output state trace files as JSON, in addition to HTML" in + Arg.(value & flag & info [ "json-trace" ] ~doc) + + let output_dir = let doc = "directory in which to output state files" in Arg.(value & opt (some string) None & info [ "output-dir" ] ~docv:"FILE" ~doc) @@ -788,6 +808,7 @@ let wf_cmd = $ Common_flags.incl_dirs $ Common_flags.incl_files $ Verify_flags.json + $ Verify_flags.json_trace $ Verify_flags.output_dir $ Common_flags.csv_times $ Common_flags.log_times @@ -824,6 +845,7 @@ let verify_t : unit Term.t = $ Verify_flags.slow_smt_dir $ Common_flags.no_timestamps $ Verify_flags.json + $ Verify_flags.json_trace $ Verify_flags.output_dir $ Verify_flags.diag $ Lemma_flags.lemmata @@ -988,6 +1010,7 @@ let instrument_cmd = $ Common_flags.print_sym_nums $ Common_flags.no_timestamps $ Verify_flags.json + $ Verify_flags.json_trace $ Verify_flags.output_dir $ Verify_flags.diag $ Verify_flags.only diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index 5406616e1..12fe7a83a 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -676,7 +676,12 @@ let mk_report_file_name error contains enough information to create an HTML state report, generate one in [output_dir] (or, failing that, the system temporary directory) and print a link to it. *) -let report_pretty ?output_dir:dir_ ?(fn_name : string option) { loc; msg } = +let report_pretty + ?output_dir:dir_ + ?(fn_name : string option) + ?(serialize_json : bool = false) + { loc; msg } + = (* stealing some logic from pp_errors *) let report = pp_message msg in let consider = @@ -685,28 +690,39 @@ let report_pretty ?output_dir:dir_ ?(fn_name : string option) { loc; msg } = let file = mk_state_file_name ?output_dir:dir_ ?fn_name loc in let link = Report.make file (Cerb_location.get_filename loc) state in let state_msg = !^"State file:" ^^^ !^("file://" ^ link) in - let report_file = mk_report_file_name ?output_dir:dir_ ?fn_name loc in - let report_js = Report.report_to_yojson state in - let () = Yojson.Safe.to_file report_file report_js in - let report_msg = !^"Report file:" ^^^ !^("file://" ^ report_file) in - [ state_msg; report_msg ] + if serialize_json then ( + let report_file = mk_report_file_name ?output_dir:dir_ ?fn_name loc in + let report_js = Report.report_to_yojson state in + let () = Yojson.Safe.to_file report_file report_js in + let report_msg = !^"Report file:" ^^^ !^("file://" ^ report_file) in + [ state_msg; report_msg ]) + else + [ state_msg ] | None -> [] in Pp.error loc report.short (Option.to_list report.descr @ consider) (* stealing some logic from pp_errors *) -let report_json ?output_dir:dir_ ?(fn_name : string option) { loc; msg } = +let report_json + ?output_dir:dir_ + ?(fn_name : string option) + ?(serialize_json : bool = false) + { loc; msg } + = let report = pp_message msg in let state_error_file, report_file = match report.state with | Some state -> let file = mk_state_file_name ?output_dir:dir_ ?fn_name loc in let link = Report.make file (Cerb_location.get_filename loc) state in - let report_file = mk_report_file_name ?output_dir:dir_ ?fn_name loc in - let report_js = Report.report_to_yojson state in - let () = Yojson.Safe.to_file report_file report_js in - (`String link, `String report_file) + if serialize_json then ( + let report_file = mk_report_file_name ?output_dir:dir_ ?fn_name loc in + let report_js = Report.report_to_yojson state in + let () = Yojson.Safe.to_file report_file report_js in + (`String link, `String report_file)) + else + (`String link, `Null) | None -> (`Null, `Null) in let descr = From bd6d833ae5b9f28ca9e063c2b6f6bf7e03468932 Mon Sep 17 00:00:00 2001 From: Sam Cowger Date: Fri, 1 Nov 2024 08:54:58 -0700 Subject: [PATCH 018/148] CN: factor out file-naming convention in error-reporting --- backend/cn/lib/typeErrors.ml | 59 ++++++++++++++++++++---------------- 1 file changed, 33 insertions(+), 26 deletions(-) diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index 12fe7a83a..3222677d8 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -634,42 +634,47 @@ let mk_output_dir (output_dir : string option) : string = Filename.get_temp_dir_name () -(** Construct a canonical filename for state output derived from the given error - location, located in [output_dir], if possible. *) -let mk_state_file_name - ?(output_dir : string option) +(** A naming convention for files that pertain to specific error locations. The + generated name will always include the user-provided [~name], which should + be a valid filename. *) +let located_file_name ?(fn_name : string option) - (loc : Cerb_location.t) + ~(dir : string) + ~(name : string) + ~(ext : string) + (error_loc : Cerb_location.t) : string = - let dir = mk_output_dir output_dir in - let file_tag = - match Cerb_location.get_filename loc with + let source_file_tag = + match Cerb_location.get_filename error_loc with | None -> "" | Some filename -> "__" ^ Filename.basename filename in let function_tag = match fn_name with None -> "" | Some fn -> "__" ^ fn in - let filename = "state" ^ file_tag ^ function_tag ^ ".html" in + let filename = name ^ source_file_tag ^ function_tag ^ ext in Filename.concat dir filename +(** Construct a canonical filename for state output derived from the given error + location, located in [output_dir]. *) +let mk_state_file_name + ?(fn_name : string option) + (output_dir : string) + (loc : Cerb_location.t) + : string + = + located_file_name ?fn_name ~dir:output_dir ~name:"state" ~ext:".html" loc + + (** Construct a canonical filename for report output derived from the given - error location, located in [output_dir], if possible. *) + error location, located in [output_dir]. *) let mk_report_file_name - ?(output_dir : string option) ?(fn_name : string option) + (output_dir : string) (loc : Cerb_location.t) : string = - let dir = mk_output_dir output_dir in - let file_tag = - match Cerb_location.get_filename loc with - | None -> "" - | Some filename -> "__" ^ Filename.basename filename - in - let function_tag = match fn_name with None -> "" | Some fn -> "__" ^ fn in - let filename = "report" ^ file_tag ^ function_tag ^ ".json" in - Filename.concat dir filename + located_file_name ?fn_name ~dir:output_dir ~name:"report" ~ext:".json" loc (** Format the error for human readability and print it to [stderr]. if the @@ -677,7 +682,7 @@ let mk_report_file_name one in [output_dir] (or, failing that, the system temporary directory) and print a link to it. *) let report_pretty - ?output_dir:dir_ + ?(output_dir : string option) ?(fn_name : string option) ?(serialize_json : bool = false) { loc; msg } @@ -687,11 +692,12 @@ let report_pretty let consider = match report.state with | Some state -> - let file = mk_state_file_name ?output_dir:dir_ ?fn_name loc in + let dir = mk_output_dir output_dir in + let file = mk_state_file_name ?fn_name dir loc in let link = Report.make file (Cerb_location.get_filename loc) state in let state_msg = !^"State file:" ^^^ !^("file://" ^ link) in if serialize_json then ( - let report_file = mk_report_file_name ?output_dir:dir_ ?fn_name loc in + let report_file = mk_report_file_name ?fn_name dir loc in let report_js = Report.report_to_yojson state in let () = Yojson.Safe.to_file report_file report_js in let report_msg = !^"Report file:" ^^^ !^("file://" ^ report_file) in @@ -705,7 +711,7 @@ let report_pretty (* stealing some logic from pp_errors *) let report_json - ?output_dir:dir_ + ?(output_dir : string option) ?(fn_name : string option) ?(serialize_json : bool = false) { loc; msg } @@ -714,10 +720,11 @@ let report_json let state_error_file, report_file = match report.state with | Some state -> - let file = mk_state_file_name ?output_dir:dir_ ?fn_name loc in + let dir = mk_output_dir output_dir in + let file = mk_state_file_name ?fn_name dir loc in let link = Report.make file (Cerb_location.get_filename loc) state in if serialize_json then ( - let report_file = mk_report_file_name ?output_dir:dir_ ?fn_name loc in + let report_file = mk_report_file_name ?fn_name dir loc in let report_js = Report.report_to_yojson state in let () = Yojson.Safe.to_file report_file report_js in (`String link, `String report_file)) From b9daa229c2e76e43494bf5c7f2eced020035ee53 Mon Sep 17 00:00:00 2001 From: Sam Cowger Date: Fri, 1 Nov 2024 09:03:43 -0700 Subject: [PATCH 019/148] CN: implement and expose `Report.labeled_view` lookup --- backend/cn/lib/report.ml | 2 ++ backend/cn/lib/report.mli | 5 ++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/backend/cn/lib/report.ml b/backend/cn/lib/report.ml index a4d23d42a..ca5942b16 100644 --- a/backend/cn/lib/report.ml +++ b/backend/cn/lib/report.ml @@ -84,6 +84,8 @@ let labeled_empty = StrMap.empty let add_labeled lab view mp = StrMap.add lab view mp +let get_labeled mp lab = StrMap.find_opt lab mp + type state_report = { where : where_report; not_given_to_solver : simp_view labeled_view; diff --git a/backend/cn/lib/report.mli b/backend/cn/lib/report.mli index 63ca65295..ca26dca4a 100644 --- a/backend/cn/lib/report.mli +++ b/backend/cn/lib/report.mli @@ -44,9 +44,12 @@ type 'a labeled_view (** Empty collection of labeld things *) val labeled_empty : 'a labeled_view -(** Set the entities assocaited with a lable *) +(** Set the entities associated with a label *) val add_labeled : label -> 'a list -> 'a labeled_view -> 'a labeled_view +(** Get any entities associated with a label *) +val get_labeled : 'a labeled_view -> label -> 'a list option + (** Information about a specific state of the computation. The resources, constraints, and terms are pairs because they classify how relevant the thing might be: From e993f0d0bd73b5e8ff3c860a6a28f708d2bb92e8 Mon Sep 17 00:00:00 2001 From: Rini Banerjee <26858592+rbanerjee20@users.noreply.github.com> Date: Mon, 4 Nov 2024 16:27:58 +0000 Subject: [PATCH 020/148] [CN-exec] Change naming convention for Owned functions (#686) --- backend/cn/lib/cn_internal_to_ail.ml | 10 +++++----- backend/cn/lib/cn_internal_to_ail.mli | 2 +- backend/cn/lib/executable_spec_internal.ml | 2 +- runtime/libcn/include/cn-executable/utils.h | 2 +- runtime/libcn/src/cn-executable/utils.c | 2 +- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 0942dba95..8ffddc586 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -742,13 +742,13 @@ let empty_for_dest : type a. a dest -> a = | PassBack -> ([], [], mk_expr empty_ail_expr) -let generate_check_ownership_function ~with_ownership_checking ctype +let generate_get_or_put_ownership_function ~with_ownership_checking ctype : A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition = let ctype_str = str_of_ctype ctype in (* Printf.printf ("ctype_str: %s\n") ctype_str; *) let ctype_str = String.concat "_" (String.split_on_char ' ' ctype_str) in - let fn_sym = Sym.fresh_pretty ("check_owned_" ^ ctype_str) in + let fn_sym = Sym.fresh_pretty ("owned_" ^ ctype_str) in let param1_sym = Sym.fresh_pretty "cn_ptr" in let cast_expr = mk_expr @@ -782,7 +782,7 @@ let generate_check_ownership_function ~with_ownership_checking ctype let param_types = List.map (fun t -> (empty_qualifiers, t, false)) param_types in let ownership_fcall_maybe = if with_ownership_checking then ( - let ownership_fn_sym = Sym.fresh_pretty "cn_check_ownership" in + let ownership_fn_sym = Sym.fresh_pretty "cn_get_or_put_ownership" in let ownership_fn_args = A. [ AilEident param2_sym; @@ -2601,7 +2601,7 @@ let cn_to_ail_resource_internal ownership_ctypes := Sctypes.to_ctype sct :: !ownership_ctypes; let ct_str = str_of_ctype (Sctypes.to_ctype sct) in let ct_str = String.concat "_" (String.split_on_char ' ' ct_str) in - let owned_fn_name = "check_owned_" ^ ct_str in + let owned_fn_name = "owned_" ^ ct_str in (* Hack with enum as sym *) let enum_val_get = IT.(IT (Sym enum_sym, BT.Integer, Cerb_location.unknown)) in let fn_call_it = @@ -2708,7 +2708,7 @@ let cn_to_ail_resource_internal ownership_ctypes := Sctypes.to_ctype sct :: !ownership_ctypes; let sct_str = str_of_ctype (Sctypes.to_ctype sct) in let sct_str = String.concat "_" (String.split_on_char ' ' sct_str) in - let owned_fn_name = "check_owned_" ^ sct_str in + let owned_fn_name = "owned_" ^ sct_str in let ptr_add_it = IT.(IT (Sym ptr_add_sym, BT.(Loc ()), Cerb_location.unknown)) in (* Hack with enum as sym *) let enum_val_get = IT.(IT (Sym enum_sym, BT.Integer, Cerb_location.unknown)) in diff --git a/backend/cn/lib/cn_internal_to_ail.mli b/backend/cn/lib/cn_internal_to_ail.mli index 29587da35..b395d6297 100644 --- a/backend/cn/lib/cn_internal_to_ail.mli +++ b/backend/cn/lib/cn_internal_to_ail.mli @@ -57,7 +57,7 @@ type ail_executable_spec = in_stmt : (Locations.t * ail_bindings_and_statements) list } -val generate_check_ownership_function +val generate_get_or_put_ownership_function : with_ownership_checking:bool -> C.ctype -> A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition diff --git a/backend/cn/lib/executable_spec_internal.ml b/backend/cn/lib/executable_spec_internal.ml index 9d8670bbc..fdb45e440 100644 --- a/backend/cn/lib/executable_spec_internal.ml +++ b/backend/cn/lib/executable_spec_internal.ml @@ -500,7 +500,7 @@ let generate_ownership_functions let ail_funs = List.map (fun ctype -> - Cn_internal_to_ail.generate_check_ownership_function + Cn_internal_to_ail.generate_get_or_put_ownership_function ~with_ownership_checking ctype) ctypes diff --git a/runtime/libcn/include/cn-executable/utils.h b/runtime/libcn/include/cn-executable/utils.h index 4c3aeac61..1f18c357a 100644 --- a/runtime/libcn/include/cn-executable/utils.h +++ b/runtime/libcn/include/cn-executable/utils.h @@ -524,7 +524,7 @@ void ownership_ghost_state_remove(signed long* address_key); void cn_get_ownership(uintptr_t generic_c_ptr, size_t size); void cn_put_ownership(uintptr_t generic_c_ptr, size_t size); void cn_assume_ownership(void *generic_c_ptr, unsigned long size, char *fun); -void cn_check_ownership(enum OWNERSHIP owned_enum, uintptr_t generic_c_ptr, size_t size); +void cn_get_or_put_ownership(enum OWNERSHIP owned_enum, uintptr_t generic_c_ptr, size_t size); /* C ownership checking */ void c_add_to_ghost_state(uintptr_t ptr_to_local, size_t size, signed long stack_depth); diff --git a/runtime/libcn/src/cn-executable/utils.c b/runtime/libcn/src/cn-executable/utils.c index 7eec0c387..9e04e4f0c 100644 --- a/runtime/libcn/src/cn-executable/utils.c +++ b/runtime/libcn/src/cn-executable/utils.c @@ -223,7 +223,7 @@ void cn_assume_ownership(void *generic_c_ptr, unsigned long size, char *fun) { } -void cn_check_ownership(enum OWNERSHIP owned_enum, uintptr_t generic_c_ptr, size_t size) { +void cn_get_or_put_ownership(enum OWNERSHIP owned_enum, uintptr_t generic_c_ptr, size_t size) { nr_owned_predicates++; switch (owned_enum) { From 322452ec2929afb6ac4cd6ff4b410ca06d0765bf Mon Sep 17 00:00:00 2001 From: Rini Banerjee <26858592+rbanerjee20@users.noreply.github.com> Date: Mon, 4 Nov 2024 17:06:42 +0000 Subject: [PATCH 021/148] [CN-exec] Enable ownership checking by default (#687) --- backend/cn/bin/main.ml | 20 ++--- backend/cn/lib/cn_internal_to_ail.ml | 74 ++++++++++++------- backend/cn/lib/cn_internal_to_ail.mli | 6 +- backend/cn/lib/executable_spec.ml | 14 ++-- backend/cn/lib/executable_spec_internal.ml | 18 ++--- backend/cn/lib/testGeneration/specTests.ml | 12 +-- backend/cn/lib/testGeneration/specTests.mli | 2 +- .../cn/lib/testGeneration/testGeneration.ml | 4 +- .../cn/lib/testGeneration/testGeneration.mli | 2 +- .../libcn/libexec/cn-runtime-single-file.sh | 12 +-- tests/cn-exec-performance-stats.py | 1 - tests/run-cn-exec.sh | 2 +- tests/run-cn-test-gen.sh | 4 +- 13 files changed, 96 insertions(+), 75 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 6e032d726..e7303b4a9 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -384,7 +384,7 @@ let generate_executable_specs (* Executable spec *) output_decorated output_decorated_dir - with_ownership_checking + without_ownership_checking with_test_gen copy_source_dir = @@ -421,7 +421,7 @@ let generate_executable_specs Cerb_colour.without_colour (fun () -> Executable_spec.main - ~with_ownership_checking + ~without_ownership_checking ~with_test_gen ~copy_source_dir filename @@ -449,7 +449,7 @@ let run_tests no_inherit_loc magic_comment_char_dollar (* Executable spec *) - with_ownership_checking + without_ownership_checking (* Test Generation *) output_dir dont_run @@ -494,7 +494,7 @@ let run_tests ("Created directory \"" ^ output_dir ^ "\" with full permissions.")); let _, sigma = ail_prog in Executable_spec.main - ~with_ownership_checking + ~without_ownership_checking ~with_test_gen:true ~copy_source_dir:false filename @@ -518,7 +518,7 @@ let run_tests TestGeneration.run ~output_dir ~filename - ~with_ownership_checking + ~without_ownership_checking config sigma prog5; @@ -773,9 +773,9 @@ module Executable_spec_flags = struct Arg.(value & opt (some string) None & info [ "output-decorated" ] ~docv:"FILE" ~doc) - let with_ownership_checking = - let doc = "Enable ownership checking within CN runtime testing" in - Arg.(value & flag & info [ "with-ownership-checking" ] ~doc) + let without_ownership_checking = + let doc = "Disable ownership checking within CN runtime testing" in + Arg.(value & flag & info [ "without-ownership-checking" ] ~doc) let with_test_gen = @@ -973,7 +973,7 @@ let testing_cmd = $ Common_flags.use_peval $ Common_flags.no_inherit_loc $ Common_flags.magic_comment_char_dollar - $ Executable_spec_flags.with_ownership_checking + $ Executable_spec_flags.without_ownership_checking $ Testing_flags.output_test_dir $ Testing_flags.dont_run_tests $ Testing_flags.gen_backtrack_attempts @@ -1026,7 +1026,7 @@ let instrument_cmd = $ Common_flags.magic_comment_char_dollar $ Executable_spec_flags.output_decorated $ Executable_spec_flags.output_decorated_dir - $ Executable_spec_flags.with_ownership_checking + $ Executable_spec_flags.without_ownership_checking $ Executable_spec_flags.with_test_gen $ Executable_spec_flags.copy_source_dir in diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 8ffddc586..4b3af6050 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -742,7 +742,7 @@ let empty_for_dest : type a. a dest -> a = | PassBack -> ([], [], mk_expr empty_ail_expr) -let generate_get_or_put_ownership_function ~with_ownership_checking ctype +let generate_get_or_put_ownership_function ~without_ownership_checking ctype : A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition = let ctype_str = str_of_ctype ctype in @@ -760,7 +760,9 @@ let generate_get_or_put_ownership_function ~with_ownership_checking ctype in let generic_c_ptr_sym = Sym.fresh_pretty "generic_c_ptr" in let generic_c_ptr_bs, generic_c_ptr_ss = - if with_ownership_checking then ( + if without_ownership_checking then + ([], []) + else ( let uintptr_t_type = C.uintptr_t in let generic_c_ptr_binding = create_binding generic_c_ptr_sym uintptr_t_type in let uintptr_t_cast_expr = @@ -770,8 +772,6 @@ let generate_get_or_put_ownership_function ~with_ownership_checking ctype A.(AilSdeclaration [ (generic_c_ptr_sym, Some uintptr_t_cast_expr) ]) in ([ generic_c_ptr_binding ], [ generic_c_ptr_assign_stat_ ])) - else - ([], []) in let param2_sym = Sym.fresh_pretty "owned_enum" in let param1 = (param1_sym, bt_to_ail_ctype BT.(Loc ())) in @@ -781,7 +781,9 @@ let generate_get_or_put_ownership_function ~with_ownership_checking ctype let param_syms, param_types = List.split [ param1; param2 ] in let param_types = List.map (fun t -> (empty_qualifiers, t, false)) param_types in let ownership_fcall_maybe = - if with_ownership_checking then ( + if without_ownership_checking then + [] + else ( let ownership_fn_sym = Sym.fresh_pretty "cn_get_or_put_ownership" in let ownership_fn_args = A. @@ -797,8 +799,6 @@ let generate_get_or_put_ownership_function ~with_ownership_checking ctype ( mk_expr (AilEident ownership_fn_sym), List.map mk_expr ownership_fn_args )))) ]) - else - [] in let deref_expr_ = A.(AilEunary (Indirection, cast_expr)) in let sct_opt = Sctypes.of_ctype ctype in @@ -3265,7 +3265,12 @@ let prepend_to_precondition ail_executable_spec (b1, s1) = (* Precondition and postcondition translation - LAT.I case means precondition translation finished *) -let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_return_type +let rec cn_to_ail_lat_internal_2 + without_ownership_checking + dts + globals + preds + c_return_type = function | LAT.Define ((name, it), _info, lat) -> let ctype = bt_to_ail_ctype (IT.bt it) in @@ -3279,7 +3284,7 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret let b1, s1 = cn_to_ail_expr_internal dts globals it (AssignVar new_name) in let ail_executable_spec = cn_to_ail_lat_internal_2 - with_ownership_checking + without_ownership_checking dts globals preds @@ -3299,7 +3304,7 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret in let ail_executable_spec = cn_to_ail_lat_internal_2 - with_ownership_checking + without_ownership_checking dts globals preds @@ -3313,7 +3318,13 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret let b1, s, e = cn_to_ail_logical_constraint_internal dts globals PassBack lc in let ss = upd_s @ s @ generate_cn_assert (*~cn_source_loc_opt:(Some loc)*) e @ pop_s in let ail_executable_spec = - cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_return_type lat + cn_to_ail_lat_internal_2 + without_ownership_checking + dts + globals + preds + c_return_type + lat in prepend_to_precondition ail_executable_spec (b1, ss) (* Postcondition *) @@ -3364,15 +3375,15 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret in let post_bs, post_ss = cn_to_ail_post_internal dts globals preds post in let ownership_stat_ = - if with_ownership_checking then ( + if without_ownership_checking then + [] + else ( let cn_stack_depth_decr_stat_ = mk_stmt (A.AilSexpr (mk_expr (AilEcall (mk_expr (AilEident OE.cn_stack_depth_decr_sym), [])))) in [ cn_stack_depth_decr_stat_ ]) - else - [] in let block = A.( @@ -3382,7 +3393,7 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret let rec cn_to_ail_pre_post_aux_internal - with_ownership_checking + without_ownership_checking dts preds globals @@ -3399,7 +3410,7 @@ let rec cn_to_ail_pre_post_aux_internal in let ail_executable_spec = cn_to_ail_pre_post_aux_internal - with_ownership_checking + without_ownership_checking dts preds globals @@ -3408,15 +3419,26 @@ let rec cn_to_ail_pre_post_aux_internal in prepend_to_precondition ail_executable_spec ([ binding ], [ decl ]) | AT.L lat -> - cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_return_type lat + cn_to_ail_lat_internal_2 + without_ownership_checking + dts + globals + preds + c_return_type + lat -let cn_to_ail_pre_post_internal ~with_ownership_checking dts preds globals c_return_type +let cn_to_ail_pre_post_internal + ~without_ownership_checking + dts + preds + globals + c_return_type = function | Some internal -> let ail_executable_spec = cn_to_ail_pre_post_aux_internal - with_ownership_checking + without_ownership_checking dts preds globals @@ -3424,20 +3446,20 @@ let cn_to_ail_pre_post_internal ~with_ownership_checking dts preds globals c_ret internal in let extra_stats_ = - if with_ownership_checking then ( + if without_ownership_checking then + [] + else ( let cn_stack_depth_incr_stat_ = A.AilSexpr (mk_expr (AilEcall (mk_expr (AilEident OE.cn_stack_depth_incr_sym), []))) in [ cn_stack_depth_incr_stat_ ]) - else - [] in prepend_to_precondition ail_executable_spec ([], extra_stats_) | None -> empty_ail_executable_spec -let generate_assume_ownership_function ~with_ownership_checking ctype +let generate_assume_ownership_function ~without_ownership_checking ctype : A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition = let ctype_str = str_of_ctype ctype in @@ -3459,7 +3481,9 @@ let generate_assume_ownership_function ~with_ownership_checking ctype let param_syms, param_types = List.split [ param1; param2 ] in let param_types = List.map (fun t -> (empty_qualifiers, t, false)) param_types in let ownership_fcall_maybe = - if with_ownership_checking then ( + if without_ownership_checking then + [] + else ( let ownership_fn_sym = Sym.fresh_pretty "cn_assume_ownership" in let ownership_fn_args = A. @@ -3475,8 +3499,6 @@ let generate_assume_ownership_function ~with_ownership_checking ctype ( mk_expr (AilEident ownership_fn_sym), List.map mk_expr ownership_fn_args )))) ]) - else - [] in let deref_expr_ = A.(AilEunary (Indirection, cast_expr)) in let sct_opt = Sctypes.of_ctype ctype in diff --git a/backend/cn/lib/cn_internal_to_ail.mli b/backend/cn/lib/cn_internal_to_ail.mli index b395d6297..9c4e995ca 100644 --- a/backend/cn/lib/cn_internal_to_ail.mli +++ b/backend/cn/lib/cn_internal_to_ail.mli @@ -58,12 +58,12 @@ type ail_executable_spec = } val generate_get_or_put_ownership_function - : with_ownership_checking:bool -> + : without_ownership_checking:bool -> C.ctype -> A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition val generate_assume_ownership_function - : with_ownership_checking:bool -> + : without_ownership_checking:bool -> C.ctype -> A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition @@ -167,7 +167,7 @@ val cn_to_ail_predicates_internal * A.sigma_tag_definition option list val cn_to_ail_pre_post_internal - : with_ownership_checking:bool -> + : without_ownership_checking:bool -> A.sigma_cn_datatype list -> (Sym.t * ResourcePredicates.definition) list -> (Sym.t * C.ctype) list -> diff --git a/backend/cn/lib/executable_spec.ml b/backend/cn/lib/executable_spec.ml index 0c731a3f9..02fc3c9d7 100644 --- a/backend/cn/lib/executable_spec.ml +++ b/backend/cn/lib/executable_spec.ml @@ -194,7 +194,7 @@ let output_to_oc oc str_list = List.iter (Stdlib.output_string oc) str_list open Executable_spec_internal let main - ?(with_ownership_checking = false) + ?(without_ownership_checking = false) ?(with_test_gen = false) ?(copy_source_dir = false) filename @@ -217,7 +217,7 @@ let main Executable_spec_records.populate_record_map instrumentation prog5; let executable_spec = generate_c_specs_internal - with_ownership_checking + without_ownership_checking instrumentation symbol_table statement_locs @@ -244,7 +244,7 @@ let main in let ownership_function_defs, ownership_function_decls = generate_ownership_functions - with_ownership_checking + without_ownership_checking Cn_internal_to_ail.ownership_ctypes sigm in @@ -326,7 +326,7 @@ let main List.map (fun (loc, _) -> (loc, [ "" ])) toplevel_locs_and_defs in let accesses_stmt_injs = - if with_ownership_checking then memory_accesses_injections ail_prog else [] + if without_ownership_checking then [] else memory_accesses_injections ail_prog in let struct_injs_with_filenames = Executable_spec_internal.generate_struct_injs sigm in let struct_injs_with_filenames = @@ -372,12 +372,12 @@ let main failwith "Input file cannot have predefined main function when passing to CN test-gen \ tooling" - else if with_ownership_checking then ( + else if without_ownership_checking then + executable_spec.pre_post + else ( (* Inject ownership init function calls and mapping and unmapping of globals into provided main function *) let global_ownership_init_pair = generate_ownership_global_assignments sigm prog5 in global_ownership_init_pair @ executable_spec.pre_post) - else - executable_spec.pre_post in (match Source_injection.( diff --git a/backend/cn/lib/executable_spec_internal.ml b/backend/cn/lib/executable_spec_internal.ml index fdb45e440..36b8dfa40 100644 --- a/backend/cn/lib/executable_spec_internal.ml +++ b/backend/cn/lib/executable_spec_internal.ml @@ -55,7 +55,7 @@ let rec extract_global_variables = function let generate_c_pres_and_posts_internal - with_ownership_checking + without_ownership_checking (instrumentation : Core_to_mucore.instrumentation) _ (sigm : _ CF.AilSyntax.sigma) @@ -71,7 +71,7 @@ let generate_c_pres_and_posts_internal let globals = extract_global_variables prog5.globs in let ail_executable_spec = Cn_internal_to_ail.cn_to_ail_pre_post_internal - ~with_ownership_checking + ~without_ownership_checking dts preds globals @@ -82,7 +82,9 @@ let generate_c_pres_and_posts_internal let post_str = generate_ail_stat_strs ail_executable_spec.post in (* C ownership checking *) let (pre_str, post_str), block_ownership_injs = - if with_ownership_checking then ( + if without_ownership_checking then + ((pre_str, post_str), []) + else ( let fn_ownership_stats_opt, block_ownership_injs = Ownership_exec.get_c_fn_local_ownership_checking_injs instrumentation.fn sigm in @@ -97,8 +99,6 @@ let generate_c_pres_and_posts_internal in (pre_post_pair, block_ownership_injs) | None -> ((pre_str, post_str), [])) - else - ((pre_str, post_str), []) in (* Needed for extracting correct location for CN statement injection *) let modify_magic_comment_loc loc = @@ -183,7 +183,7 @@ let generate_c_assume_pres_internal (* Core_to_mucore.instrumentation list -> executable_spec *) let generate_c_specs_internal - with_ownership_checking + without_ownership_checking instrumentation_list type_map (_ : Cerb_location.t CStatements.LocMap.t) @@ -192,7 +192,7 @@ let generate_c_specs_internal = let generate_c_spec (instrumentation : Core_to_mucore.instrumentation) = generate_c_pres_and_posts_internal - with_ownership_checking + without_ownership_checking instrumentation type_map sigm @@ -482,7 +482,7 @@ let generate_c_predicates_internal let generate_ownership_functions - with_ownership_checking + without_ownership_checking ownership_ctypes (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) = @@ -501,7 +501,7 @@ let generate_ownership_functions List.map (fun ctype -> Cn_internal_to_ail.generate_get_or_put_ownership_function - ~with_ownership_checking + ~without_ownership_checking ctype) ctypes in diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 95dcee75e..909b1be8a 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -219,7 +219,7 @@ let compile_random_tests let compile_assumes - ~(with_ownership_checking : bool) + ~(without_ownership_checking : bool) (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) (insts : Core_to_mucore.instrumentation list) @@ -230,7 +230,7 @@ let compile_assumes (List.map (fun ctype -> Cn_internal_to_ail.generate_assume_ownership_function - ~with_ownership_checking + ~without_ownership_checking ctype) (let module CtypeSet = Set.Make (struct @@ -261,7 +261,7 @@ let compile_assumes let compile_tests - ~(with_ownership_checking : bool) + ~(without_ownership_checking : bool) (filename_base : string) (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) @@ -295,7 +295,7 @@ let compile_tests ^^ twice hardline ^^ pp_label "Assume Ownership Functions" ^^ twice hardline - ^^ compile_assumes ~with_ownership_checking sigma prog5 insts + ^^ compile_assumes ~without_ownership_checking sigma prog5 insts ^^ pp_label "Unit tests" ^^ twice hardline ^^ unit_tests_doc @@ -487,7 +487,7 @@ let save ?(perm = 0o666) (output_dir : string) (filename : string) (doc : Pp.doc let generate ~(output_dir : string) ~(filename : string) - ~(with_ownership_checking : bool) + ~(without_ownership_checking : bool) (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) : unit @@ -510,7 +510,7 @@ let generate let generators_fn = filename_base ^ "_gen.h" in save output_dir generators_fn generators_doc; let tests_doc = - compile_tests ~with_ownership_checking filename_base sigma prog5 insts + compile_tests ~without_ownership_checking filename_base sigma prog5 insts in let test_file = filename_base ^ "_test.c" in save output_dir test_file tests_doc; diff --git a/backend/cn/lib/testGeneration/specTests.mli b/backend/cn/lib/testGeneration/specTests.mli index 90d019cba..a6726e89a 100644 --- a/backend/cn/lib/testGeneration/specTests.mli +++ b/backend/cn/lib/testGeneration/specTests.mli @@ -4,7 +4,7 @@ module A = CF.AilSyntax val generate : output_dir:string -> filename:string -> - with_ownership_checking:bool -> + without_ownership_checking:bool -> CF.GenTypes.genTypeCategory A.sigma -> unit Mucore.file -> unit diff --git a/backend/cn/lib/testGeneration/testGeneration.ml b/backend/cn/lib/testGeneration/testGeneration.ml index 684139381..b91610659 100644 --- a/backend/cn/lib/testGeneration/testGeneration.ml +++ b/backend/cn/lib/testGeneration/testGeneration.ml @@ -7,7 +7,7 @@ let default_cfg : config = Config.default let run ~output_dir ~filename - ~with_ownership_checking + ~without_ownership_checking (cfg : config) (sigma : Cerb_frontend.GenTypes.genTypeCategory Cerb_frontend.AilSyntax.sigma) (prog5 : unit Mucore.file) @@ -17,5 +17,5 @@ let run if Option.is_some prog5.main then failwith "Cannot test a file with a `main` function"; Cerb_debug.begin_csv_timing (); - SpecTests.generate ~output_dir ~filename ~with_ownership_checking sigma prog5; + SpecTests.generate ~output_dir ~filename ~without_ownership_checking sigma prog5; Cerb_debug.end_csv_timing "specification test generation" diff --git a/backend/cn/lib/testGeneration/testGeneration.mli b/backend/cn/lib/testGeneration/testGeneration.mli index 8bda60b43..d20712e81 100644 --- a/backend/cn/lib/testGeneration/testGeneration.mli +++ b/backend/cn/lib/testGeneration/testGeneration.mli @@ -5,7 +5,7 @@ val default_cfg : config val run : output_dir:string -> filename:string -> - with_ownership_checking:bool -> + without_ownership_checking:bool -> config -> Cerb_frontend.GenTypes.genTypeCategory Cerb_frontend.AilSyntax.sigma -> unit Mucore.file -> diff --git a/runtime/libcn/libexec/cn-runtime-single-file.sh b/runtime/libcn/libexec/cn-runtime-single-file.sh index 1d33d3a37..cdf35555c 100755 --- a/runtime/libcn/libexec/cn-runtime-single-file.sh +++ b/runtime/libcn/libexec/cn-runtime-single-file.sh @@ -1,7 +1,7 @@ #!/bin/bash set -euo pipefail -o noclobber -USAGE="USAGE: $0 -h\n $0 [-ovq] FILE.c" +USAGE="USAGE: $0 -h\n $0 [-nvq] FILE.c" function echo_and_err() { printf "$1\n" @@ -9,16 +9,16 @@ function echo_and_err() { } QUIET="" -CHECK_OWNERSHIP="" +NO_CHECK_OWNERSHIP="" -while getopts "hoq" flag; do +while getopts "hnq" flag; do case "$flag" in h) printf "${USAGE}" exit 0 ;; - o) - CHECK_OWNERSHIP="--with-ownership-checking" + n) + NO_CHECK_OWNERSHIP="--without-ownership-checking" ;; q) QUIET=1 @@ -57,7 +57,7 @@ EXEC_DIR=$(mktemp -d -t 'cn-exec.XXXX') if cn instrument "${INPUT_FN}" \ --output-decorated="${INPUT_BASENAME}-exec.c" \ --output-decorated-dir="${EXEC_DIR}" \ - ${CHECK_OWNERSHIP}; then + ${NO_CHECK_OWNERSHIP}; then [ "${QUIET}" ] || echo "Generating C files from CN-annotated source." else echo_and_err "Failed to generate C files from CN-annotatated source." diff --git a/tests/cn-exec-performance-stats.py b/tests/cn-exec-performance-stats.py index d5a8280d9..6dc5138e8 100755 --- a/tests/cn-exec-performance-stats.py +++ b/tests/cn-exec-performance-stats.py @@ -85,7 +85,6 @@ def gen_instr_cmd(f, input_basename): instr_cmd_prefix = "cn instrument" instr_cmd = time_cmd_str + instr_cmd_prefix + " " + tests_path + "/" + f instr_cmd += " --output-decorated=" + input_basename + "-exec.c" - instr_cmd += " --with-ownership-checking" return instr_cmd def gen_compile_cmd(input_basename, instrumented): diff --git a/tests/run-cn-exec.sh b/tests/run-cn-exec.sh index 9952f0781..23e917226 100755 --- a/tests/run-cn-exec.sh +++ b/tests/run-cn-exec.sh @@ -17,7 +17,7 @@ CHECK_SCRIPT="${RUNTIME_PREFIX}/libexec/cn-runtime-single-file.sh" [ -f "${CHECK_SCRIPT}" ] || echo_and_err "Could not find single file helper script: ${CHECK_SCRIPT}" -SCRIPT_OPT="-oq" +SCRIPT_OPT="-q" function exits_with_code() { local file=$1 diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index 2ecfc72da..4e93c2a3b 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -33,7 +33,7 @@ for TEST in $FILES; do # Run passing tests if [[ $TEST == *.pass.c ]]; then - $CN test "$TEST" --output-dir="test" --with-ownership-checking + $CN test "$TEST" --output-dir="test" RET=$? if [[ "$RET" != 0 ]]; then echo @@ -50,7 +50,7 @@ for TEST in $FILES; do # Run failing tests if [[ $TEST == *.fail.c ]]; then - $CN test "$TEST" --output-dir="test" --with-ownership-checking + $CN test "$TEST" --output-dir="test" RET=$? if [[ "$RET" = 0 ]]; then echo From f50bbba5d3546060dd61875e388a4724a1cffc80 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Mon, 4 Nov 2024 14:56:38 +0000 Subject: [PATCH 022/148] CN: Update README.md --- backend/cn/README.md | 53 +++++++++++++++++++++++--------------------- 1 file changed, 28 insertions(+), 25 deletions(-) diff --git a/backend/cn/README.md b/backend/cn/README.md index 208ec185a..462558c92 100644 --- a/backend/cn/README.md +++ b/backend/cn/README.md @@ -10,38 +10,41 @@ Below are the installation instructions for installing Cerberus, CN, and their dependencies. -1. Install a recent version of OCaml (we are using 5.0.0 -- 5.2.0) and the opam -package manager for OCaml, following the instructions at -. (Remember to initialise opam -via `opam init` after the installation of opam.) - -2. Install the GMP and MPFR libraries, and Z3. On a Ubuntu system this is done via `sudo apt install libgmp-dev libmpfr-dev z3` . - -3. Install the `dune` OCaml build system and Lem via - - ``` - opam install dune lem - ``` - -4. Obtain a copy of Cerberus (including CN) by running - - ``` - git clone https://github.com/rems-project/cerberus.git - ``` +1. Install make, git, GMP library, pkg-config and either/both Z3 or CVC5. + On an Ubuntu system this is done via + ``` + sudo apt install build-essential libgmp-dev pkg-config z3 + ``` + Note: there is a [known bug with Z3 version + 4.8.13](https://github.com/rems-project/cerberus/issues/663) (the default on + Ubuntu 22.04) so you may wish to install Z3 via opam later for a more + up-to-date version. CVC5 -5. In the downloaded `cerberus` directory run the following opam - command to install CN's opam-package dependencies. +2. Install the opam package manager for OCaml: + https://ocaml.org/docs/installing-ocaml#install-opam. + On Ubuntu, `sudo apt install opam`. - ``` - opam install --deps-only ./cerberus-lib.opam ./cn.opam - ``` +3. Initialise opam with a recent version of OCaml (the CI builds with 4.14.1, + CN developers use 5.2.0). + ``` + opam init --yes --compiler=5.2.0 + ```` -6. then run +4. Clone the Cerberus repo (which includes CN): + ``` + git clone https://github.com/rems-project/cerberus.git + ``` +5. For CN end users, who don't want to tinker with CN locally: ``` - make install_cn + opam install --yes ./cerberus.opam ./cerberus-lib.opam ./cn.opam # z3 for a more recent version ``` +6. For CN developers: + ``` + opam install --deps-only ./cerberus.opam ./cerberus-lib.opam ./cn.opam ocamlformat.0.26.2 # one time + make install_cn # after any edits + ``` which installs Cerberus, CN (as both a library and an executable), and dependencies. From 93856fbe9c41113f7876a368079612b0a4a327c6 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Fri, 1 Nov 2024 22:45:34 -0400 Subject: [PATCH 023/148] [CN-Test-Gen] Default unfolds all non-recursive preds --- backend/cn/bin/main.ml | 4 +++- backend/cn/lib/testGeneration/genInline.ml | 11 ++++++++--- backend/cn/lib/testGeneration/testGenConfig.ml | 4 ++-- backend/cn/lib/testGeneration/testGenConfig.mli | 4 ++-- 4 files changed, 15 insertions(+), 8 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index e7303b4a9..b30c2e347 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -903,7 +903,9 @@ module Testing_flags = struct let gen_max_unfolds = let doc = "Set the maximum number of unfolds for recursive generators" in Arg.( - value & opt int TestGeneration.default_cfg.max_unfolds & info [ "max-unfolds" ] ~doc) + value + & opt (some int) TestGeneration.default_cfg.max_unfolds + & info [ "max-unfolds" ] ~doc) let test_max_array_length = diff --git a/backend/cn/lib/testGeneration/genInline.ml b/backend/cn/lib/testGeneration/genInline.ml index cf471577d..f23af0f14 100644 --- a/backend/cn/lib/testGeneration/genInline.ml +++ b/backend/cn/lib/testGeneration/genInline.ml @@ -3,8 +3,8 @@ module GT = GenTerms module GD = GenDefinitions let unfold (ctx : GD.context) : GD.context = - let rec loop (fuel : int) (gd : GD.t) : GD.t = - if fuel <= 0 then + let rec loop (fuel : int option) (gd : GD.t) : GD.t = + if Option.equal Int.equal fuel (Some 0) then gd else ( let aux (gt : GT.t) : GT.t = @@ -22,7 +22,12 @@ let unfold (ctx : GD.context) : GD.context = GT.subst (IT.make_subst iargs) (Option.get gd'.body) | _ -> gt in - loop (fuel - 1) { gd with body = Some (GT.map_gen_post aux (Option.get gd.body)) }) + let gt = Option.get gd.body in + let gt' = GT.map_gen_post aux gt in + if GT.equal gt gt' then + { gd with body = Some gt' } + else + loop (Option.map (fun x -> x - 1) fuel) { gd with body = Some gt' }) in List.map_snd (List.map_snd (loop (TestGenConfig.get_max_unfolds ()))) ctx diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index 4f80f0d0b..edb4f6781 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -1,7 +1,7 @@ type t = { (* Compile time *) max_backtracks : int; - max_unfolds : int; + max_unfolds : int option; max_array_length : int; (* Run time *) null_in_every : int option; @@ -14,7 +14,7 @@ type t = let default = { max_backtracks = 25; - max_unfolds = 5; + max_unfolds = None; max_array_length = 50; null_in_every = None; seed = None; diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 1fe6eaea0..4b9918e4e 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -1,7 +1,7 @@ type t = { (* Compile time *) max_backtracks : int; - max_unfolds : int; + max_unfolds : int option; max_array_length : int; (* Run time *) null_in_every : int option; @@ -18,7 +18,7 @@ val initialize : t -> unit val get_max_backtracks : unit -> int -val get_max_unfolds : unit -> int +val get_max_unfolds : unit -> int option val get_max_array_length : unit -> int From 775b703a86a6ff81de4bddfa5bc286aede5ae5db Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 4 Nov 2024 10:41:17 -0500 Subject: [PATCH 024/148] [CN-Test-Gen] More conservative splitting of `||`s --- backend/cn/lib/testGeneration/genOptimize.ml | 61 ++- tests/cn-test-gen/src/bst.pass.c | 371 +++++++++++++++++++ 2 files changed, 426 insertions(+), 6 deletions(-) create mode 100644 tests/cn-test-gen/src/bst.pass.c diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 69bca7478..b9c7ce224 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -1506,6 +1506,19 @@ module SplitConstraints = struct let pass = { name; transform } end + let rec is_external (gt : GT.t) : bool = + let (GT (gt_, _, _)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Return _ -> false + | Call _ -> true + | Pick wgts -> wgts |> List.map snd |> List.exists is_external + | Asgn (_, _, gt_rest) -> is_external gt_rest + | Let (_, (_, gt_inner), gt_rest) -> is_external gt_inner || is_external gt_rest + | Assert (_, gt_rest) -> is_external gt_rest + | ITE (_, gt_then, gt_else) -> is_external gt_then || is_external gt_else + | Map (_, gt_inner) -> is_external gt_inner + + module Disjunction = struct let name = "split_disjunction" @@ -1557,23 +1570,59 @@ module SplitConstraints = struct let transform (gt : GT.t) : GT.t = - let aux (gt : GT.t) : GT.t = + let rec aux (ext : SymSet.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt + | Pick wgts -> GT.pick_ (List.map_snd (aux ext) wgts) loc + | Asgn ((it_addr, sct), it_val, gt_rest) -> + GT.asgn_ ((it_addr, sct), it_val, aux ext gt_rest) loc + | Let (backtracks, (x, gt_inner), gt_rest) -> + let gt_inner = aux ext gt_inner in + let ext = if is_external gt_inner then SymSet.add x ext else ext in + GT.let_ (backtracks, (x, gt_inner), aux ext gt_rest) loc | Assert (T it, gt') -> let it = dnf it in + let gt' = aux ext gt' in (match it with | IT (Binop (Or, _, _), _, _) -> - let cases = + let its_split, its_left = it |> listify_constraints - |> List.map (fun it' -> (Z.one, GT.assert_ (T it', gt') loc)) + |> List.partition (fun it' -> + match it with + | IT (Binop (EQ, IT (Sym x, _, _), _), _, _) when not (SymSet.mem x ext) + -> + true + | IT (Binop (EQ, _, IT (Sym x, _, _)), _, _) when not (SymSet.mem x ext) + -> + true + | _ -> SymSet.disjoint ext (IT.free_vars it')) + in + let gt' = + if List.is_empty its_left then + gt' + else ( + let it' = + List.fold_left + (fun it1 it2 -> IT.or2_ (it1, it2) loc) + (List.hd its_left) + (List.tl its_left) + in + GT.assert_ (T it', gt') loc) + in + let cases = + its_split |> List.map (fun it' -> (Z.one, GT.assert_ (T it', gt') loc)) in GT.pick_ cases loc - | _ -> gt) - | _ -> gt + | _ -> GT.assert_ (T it, gt') loc) + | Assert ((Forall _ as lc), gt_rest) -> GT.assert_ (lc, aux ext gt_rest) loc + | ITE (it_if, gt_then, gt_else) -> + GT.ite_ (it_if, aux ext gt_then, aux ext gt_else) loc + | Map ((i, i_bt, it_perm), gt_inner) -> + GT.map_ ((i, i_bt, it_perm), aux ext gt_inner) loc in - GT.map_gen_pre aux gt + aux SymSet.empty gt let pass = { name; transform } diff --git a/tests/cn-test-gen/src/bst.pass.c b/tests/cn-test-gen/src/bst.pass.c new file mode 100644 index 000000000..0881e3542 --- /dev/null +++ b/tests/cn-test-gen/src/bst.pass.c @@ -0,0 +1,371 @@ +/* A set defined as binary search tree */ + +struct MapNode { + int key; + int ignore; + long value; + struct MapNode* smaller; + struct MapNode* larger; +}; +struct MapNode* malloc_MapNode(); +struct Map { + struct MapNode* root; +}; +struct Map map_empty(); +_Bool map_lookup(struct Map map, int key, long* value); + +// Functional Sepcification of Binary Search Tree +/*@ +type_synonym KEY = i32 +type_synonym VALUE = i64 +type_synonym NodeData = { KEY key, VALUE value } + +type_synonym Interval = { KEY lower, KEY upper, boolean empty } + +function (Interval) emptyInterval() { + { lower: 0i32, upper: 0i32, empty: true } +} + + + +function (Interval) joinInterval(Interval smaller, Interval larger) { + if (smaller.empty) { + larger + } else { + if (larger.empty) { + smaller + } else { + { lower: smaller.lower, upper: larger.upper, empty: false } + }} +} + +// A binary dearch tree +datatype BST { + Leaf {}, + Node { NodeData data, BST smaller, BST larger } +} + +// A selector for the case when we know that the tree is a `Node`. +function ({ NodeData data, BST smaller, BST larger }) fromBSTNode(BST node) { + match node { + Leaf {} => { { data: { key: 0i32, value: 0i64 }, smaller: Leaf {}, larger: Leaf {} } } + Node { data: data, smaller: smaller, larger: larger } => { + { data: data, smaller: smaller, larger: larger } + } + } +} + + +function [rec] (VALUE) lookup(KEY key, BST tree) { + match tree { + Leaf {} => { 0i64 } + Node { data: data, smaller: smaller, larger: larger } => { + if (data.key == key) { + data.value + } else { + if (data.key < key) { + lookup(key,larger) + } else { + lookup(key,smaller) + } + } + } + } +} + +function [rec] (boolean) member(KEY k, BST tree) { + match tree { + Leaf {} => { false } + Node { data: data, smaller: smaller, larger: larger } => { + data.key == k || + k < data.key && member(k,smaller) || + k > data.key && member(k,larger) + } + } +} + +function [rec] (BST) insert(KEY key, VALUE value, BST tree) { + match tree { + Leaf {} => { Node { data: { key: key, value: value }, smaller: Leaf {}, larger: Leaf {} } } + Node { data: data, smaller: smaller, larger: larger } => { + if (data.key == key) { + Node { data: { key: key, value: value }, smaller: smaller, larger: larger } + } else { + if (data.key < key) { + Node { data: data, smaller: smaller, larger: insert(key,value,larger) } + } else { + Node { data: data, smaller: insert(key,value,smaller), larger: larger } + } + } + } + } +} + + + +function [rec] (BST) setKey(KEY k, BST root, BST value) { + match root { + Leaf {} => { value } + Node { data: data, smaller: smaller, larger: larger } => { + if (k < data.key) { + Node { data: data, smaller: setKey(k, smaller, value), larger: larger } + } else { + Node { data: data, smaller: smaller, larger: setKey(k, larger, value) } + } + } + } +} + + +@*/ + +// Specialized `malloc` +extern struct MapNode* malloc_MapNode(); +/*@ +spec malloc_MapNode(); +requires + true; +ensures + take v = Block(return); +@*/ +/*@ + +// ***************************************************************************** +// Consuming an entire tree +// ***************************************************************************** + + +// Semantic data stored at a node +function (NodeData) getNodeData(struct MapNode node) { + { key: node.key, value: node.value } +} + +type_synonym RangedBST = { BST tree, Interval range } +type_synonym RangedNode = { + struct MapNode node, + BST smaller, + BST larger, + Interval range +} + +function (boolean) validBST(struct MapNode node, Interval smaller, Interval larger) { + (smaller.empty || smaller.upper < node.key) && + (larger.empty || node.key < larger.lower) +} + + +predicate RangedNode RangedNode(pointer root) { + take node = Owned(root); + take smaller = RangedBST(node.smaller); + take larger = RangedBST(node.larger); + assert (validBST(node, smaller.range, larger.range)); + return { node: node, smaller: smaller.tree, larger: larger.tree, + range: joinInterval(smaller.range, larger.range) }; +} + +// A binary search tree, and the interval for all its keys. +predicate RangedBST RangedBST(pointer root) { + if (is_null(root)) { + return { tree: Leaf {}, range: emptyInterval() }; + } else { + take node = RangedNode(root); + let data = getNodeData(node.node); + return { tree: Node { data: data, smaller: node.smaller, larger: node.larger }, + range: node.range }; + } +} + +// An arbitrary binary search tree. +predicate BST BST(pointer root) { + take result = RangedBST(root); + return result.tree; +} + + + + +// ***************************************************************************** +// Focusing on a node in the tree +// ***************************************************************************** + +type_synonym BSTNodeFocus = + { BST done, struct MapNode node, BST smaller, BST larger } + +datatype BSTFocus { + AtLeaf { BST tree }, + AtNode { BST done, struct MapNode node, BST smaller, BST larger } +} + +function (struct MapNode) default_map_node() { + struct MapNode { + key: 0i32, + ignore: 0i32, + value: 0i64, + smaller: NULL, + larger: NULL + } +} + +function (BSTNodeFocus) default_node_focus() { + { done: Leaf {}, node: default_map_node(), smaller: Leaf {}, larger: Leaf {} } +} + +// Access focus data, when we already know that we are at a node. +function (BSTNodeFocus) fromBSTFocusNode(BSTFocus focus) { + match focus { + AtLeaf { tree: _ } => { default_node_focus() } + AtNode { done: done, node: node, smaller: smaller, larger: larger } => { + { done: done, node: node, smaller: smaller, larger: larger } + } + } +} + +predicate BSTFocus BSTFocus(pointer root, pointer child) { + if (is_null(child)) { + take tree = BST(root); + return AtLeaf { tree: tree }; + } else { + take node = RangedNode(child); + take result = BSTNodeUpTo(root, child, node.node, node.range); + return AtNode { done: result.tree, node: node.node, + smaller: node.smaller, larger: node.larger }; + } +} + +// Consume parts of the tree starting at `p` until we get to `c`. +// We do not consume `c`. +// `child` is the node stored at `c`. +predicate RangedBST BSTNodeUpTo(pointer p, pointer c, struct MapNode child, Interval range) { + if (ptr_eq(p,c)) { + return { tree: Leaf {}, range: range }; + } else { + take parent = Owned(p); + take result = BSTNodeChildUpTo(c, child, range, parent); + return result; + } +} + +// Starting at a parent with data `data` and children `smaller` and `larger`, +// we go toward `c`, guided by its value, `target`. +predicate RangedBST + BSTNodeChildUpTo(pointer c, struct MapNode target, Interval range, struct MapNode parent) { + if (parent.key < target.key) { + take small = RangedBST(parent.smaller); + take large = BSTNodeUpTo(parent.larger, c, target, range); + assert(validBST(parent, small.range, large.range)); + return { tree: Node { data: getNodeData(parent), smaller: small.tree, larger: large.tree }, + range: joinInterval(small.range,large.range) }; + } else { + if (parent.key > target.key) { + take small = BSTNodeUpTo(parent.smaller, c, target, range); + take large = RangedBST(parent.larger); + assert(validBST(parent, small.range, large.range)); + return { tree: Node { data: getNodeData(parent), smaller: small.tree, larger: large.tree }, + range: joinInterval(small.range,large.range) }; + } else { + // We should never get here, but asserting `false` is not allowed + return { tree: Leaf {}, range: emptyInterval() }; + }} +} + +function (BST) unfocus(BSTFocus focus) { + match focus { + AtLeaf { tree: tree } => { tree } + AtNode { done: tree, node: node, smaller: smaller, larger: larger } => { + let bst = Node { data: getNodeData(node), smaller: smaller, larger: larger }; + setKey(node.key, tree, bst) + } + } +} + +function (BST) focusDone(BSTFocus focus) { + match focus { + AtLeaf { tree: tree } => { tree } + AtNode { done: tree, node: _, smaller: _, larger: _ } => { tree } + } +} + + + +lemma FocusedGo(pointer root, pointer cur, boolean smaller) + requires + !is_null(cur); + take focus = BSTFocus(root,cur); + ensures + let node = fromBSTFocusNode(focus).node; + take new_focus = BSTFocus(root, if (smaller) { node.smaller } else { node.larger }); + unfocus(focus) == unfocus(new_focus); + + +// It's quite unfortunate that we have to copy the lemma here. +lemma FocusedGoKey(pointer root, pointer cur, boolean smaller, KEY key) + requires + !is_null(cur); + take focus = BSTFocus(root,cur); + ensures + let node = fromBSTFocusNode(focus).node; + take new_focus = BSTFocus(root, if (smaller) { node.smaller } else { node.larger }); + unfocus(focus) == unfocus(new_focus); + + if (!member(key, focusDone(focus)) && node.key != key) { + !member(key, focusDone(new_focus)) + } else { + true + }; + + + +@*/ +/* Look for a node and its parent */ +struct MapNode* findNode(struct MapNode* root, int key) + /*@ + requires + take tree = BST(root); + ensures + take focus = BSTFocus(root, return); + unfocus(focus) == tree; + match focus { + AtLeaf { tree: _ } => { !member(key,tree) } + AtNode { done: _, node: node, smaller: _, larger: _ } => { + node.key == key + } + }; + @*/ +{ + struct MapNode* cur = root; + /*@ split_case is_null(cur); @*/ + /*@ unfold setKey(fromBSTNode(tree).data.key, Leaf {}, tree); @*/ + /*@ unfold member(key, Leaf {}); @*/ + while (cur) + /*@ inv + {root} unchanged; + {key} unchanged; + take focus = BSTFocus(root,cur); + unfocus(focus) == tree; + !member(key, focusDone(focus)); + let cur_prev = cur; + @*/ + { + int k = cur->key; + if (k == key) return cur; + cur = k < key ? cur->larger : cur->smaller; + /*@ apply FocusedGoKey(root, cur_prev, k > key, key); @*/ + } + return 0; +} +/*@ +predicate BSTFocus FindParentFocus(pointer tree_ptr, pointer cur_ptr, pointer parent_ptr, KEY key) { + if (is_null(cur_ptr)) { + take focus = BSTFocus(tree_ptr, parent_ptr); + let tree_after = unfocus(focus); + assert(!member(key,tree_after)); // More? + return focus; + } else { + // Found in tree + take focus = BSTFocus(tree_ptr, cur_ptr); + let at_node = fromBSTFocusNode(focus); + assert(at_node.node.key == key); + return focus; + } +} +@*/ \ No newline at end of file From fce8e989744678185df42f3875891e0c84d048b3 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 4 Nov 2024 11:02:56 -0500 Subject: [PATCH 025/148] [CN-Test-Gen] Ensure empty record is generated in C --- backend/cn/bin/main.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index b30c2e347..d2f66ca96 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -493,6 +493,7 @@ let run_tests print_endline ("Created directory \"" ^ output_dir ^ "\" with full permissions.")); let _, sigma = ail_prog in + Cn_internal_to_ail.augment_record_map (BaseTypes.Record []); Executable_spec.main ~without_ownership_checking ~with_test_gen:true From 4ae4dba0e15cc26ed9757835f0b6786f44804882 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 4 Nov 2024 11:04:06 -0500 Subject: [PATCH 026/148] [CN-Test-Gen] Fix result initialization in runtime Previously only initialized the first value to "skip", now all are initialized. --- runtime/libcn/src/cn-testing/test.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index df96f8e0a..57e12e26a 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -101,7 +101,8 @@ int cn_test_main(int argc, char* argv[]) { cn_gen_rand(); // Junk to get something to make a checkpoint from cn_gen_rand_checkpoint checkpoints[CN_TEST_MAX_TEST_CASES]; - enum cn_test_result results[CN_TEST_MAX_TEST_CASES] = { CN_TEST_SKIP }; + enum cn_test_result results[CN_TEST_MAX_TEST_CASES]; + memset(results, CN_TEST_SKIP, CN_TEST_MAX_TEST_CASES * sizeof(enum cn_test_result)); int timediff = 0; From dee4dcbf435aed452eda2874d221ddc09ffee595 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 4 Nov 2024 11:05:34 -0500 Subject: [PATCH 027/148] [CN-Test-Gen] Fuse asserts on recursive preds results --- backend/cn/lib/testGeneration/genOptimize.ml | 201 ++++++++++++++++++- 1 file changed, 200 insertions(+), 1 deletion(-) diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index b9c7ce224..929a2b868 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -224,6 +224,192 @@ module Fusion = struct in { gd with body } end + + module Recursive = struct + let collect_constraints (vars : SymSet.t) (x : Sym.t) (gt : GT.t) : GT.t * LC.t list = + let rec aux (gt : GT.t) : GT.t * LC.t list = + let (GT (gt_, _, loc)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ | Pick _ | ITE _ | Map _ -> + (gt, []) + | Asgn ((it_addr, sct), it_val, gt_rest) -> + let gt_rest, lcs = aux gt_rest in + (GT.asgn_ ((it_addr, sct), it_val, gt_rest) loc, lcs) + | Let (backtracks, (x, gt_inner), gt_rest) -> + let gt_inner, lcs = aux gt_inner in + let gt_rest, lcs' = aux gt_rest in + (GT.let_ (backtracks, (x, gt_inner), gt_rest) loc, lcs @ lcs') + | Assert ((T (IT (Binop (EQ, IT (Sym y, _, _), _), _, _)) as lc), gt_rest) + when not (Sym.equal x y) -> + let gt_rest, lcs = aux gt_rest in + (GT.assert_ (lc, gt_rest) loc, lcs) + | Assert ((T (IT (Binop (EQ, _, IT (Sym y, _, _)), _, _)) as lc), gt_rest) + when not (Sym.equal x y) -> + let gt_rest, lcs = aux gt_rest in + (GT.assert_ (lc, gt_rest) loc, lcs) + | Assert (lc, gt_rest) + when let free_vars = LC.free_vars lc in + SymSet.mem x free_vars && SymSet.subset free_vars vars -> + let gt_rest, lcs = aux gt_rest in + (gt_rest, lc :: lcs) + | Assert (lc, gt_rest) -> + let gt_rest, lcs = aux gt_rest in + (GT.assert_ (lc, gt_rest) loc, lcs) + in + aux gt + + + type inline_request = + { old_name : Sym.t; + old_args : (Sym.t * BT.t) list; + ret_sym : Sym.t; + new_name : Sym.t; + new_args : (Sym.t * BT.t) list; + constraints : LC.t list + } + + let request_gt (vars : SymSet.t) (gt : GT.t) : GT.t * inline_request list = + let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t * inline_request list = + let (GT (gt_, _, loc)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> (gt, []) + | Pick wgts -> + let wgts, reqs = + wgts + |> List.map (fun (w, gt') -> + let gt'', reqs = aux vars gt' in + ((w, gt''), reqs)) + |> List.split + in + (GT.pick_ wgts loc, List.flatten reqs) + | Asgn ((it_addr, sct), it_val, gt_rest) -> + let gt_rest, reqs = aux vars gt_rest in + (GT.asgn_ ((it_addr, sct), it_val, gt_rest) loc, reqs) + | Let (backtracks, (x, GT (Call (fsym, xits), bt_call, loc_call)), gt_rest) -> + let gt_rest, lcs = collect_constraints (SymSet.add x vars) x gt_rest in + let gt_rest, reqs = aux (SymSet.add x vars) gt_rest in + if List.is_empty lcs then + ( GT.let_ + (backtracks, (x, GT.call_ (fsym, xits) bt_call loc_call), gt_rest) + loc, + reqs ) + else ( + let old_args = List.map_snd IT.bt xits in + let ret_sym = Sym.fresh_make_uniq (Sym.pp_string x) in + let xits' = + lcs + |> List.map LC.free_vars_bts + |> List.fold_left + (SymMap.union (fun _ bt1 bt2 -> + assert (BT.equal bt1 bt2); + Some bt1)) + SymMap.empty + |> SymMap.remove x + |> SymMap.to_seq + |> List.of_seq + |> List.map (fun (y, y_bt) -> + (Sym.fresh (), IT.sym_ (y, y_bt, Locations.other __LOC__))) + in + let subst = + (x, IT.sym_ (ret_sym, bt_call, Locations.other __LOC__)) + :: (xits' + |> List.map (fun (y, it) -> + ( fst (Option.get (IT.is_sym it)), + IT.sym_ (y, IT.bt it, Locations.other __LOC__) ))) + in + let lcs = List.map (LC.subst (IT.make_subst subst)) lcs in + let new_name = Sym.fresh_make_uniq (Sym.pp_string fsym) in + let new_args = xits' |> List.map (fun (y, it) -> (y, IT.bt it)) in + ( GT.let_ + ( backtracks, + (x, GT.call_ (new_name, xits @ xits') bt_call loc_call), + gt_rest ) + loc, + { old_name = fsym; + old_args; + ret_sym; + new_name; + new_args; + constraints = lcs + } + :: reqs )) + | Let (backtracks, (x, gt_inner), gt_rest) -> + let gt_inner, reqs = aux vars gt_inner in + let gt_rest, reqs' = aux (SymSet.add x vars) gt_rest in + (GT.let_ (backtracks, (x, gt_inner), gt_rest) loc, reqs @ reqs') + | Assert (lc, gt_rest) -> + let gt_rest, reqs = aux vars gt_rest in + (GT.assert_ (lc, gt_rest) loc, reqs) + | ITE (it_if, gt_then, gt_else) -> + let gt_then, reqs = aux vars gt_then in + let gt_else, reqs' = aux vars gt_else in + (GT.ite_ (it_if, gt_then, gt_else) loc, reqs @ reqs') + | Map ((i, i_bt, it_perm), gt_inner) -> + let gt_inner, reqs = aux (SymSet.add i vars) gt_inner in + (GT.map_ ((i, i_bt, it_perm), gt_inner) loc, reqs) + in + aux vars gt + + + let request_gd (gd : GD.t) : GD.t * inline_request list = + let gt, reqs = + request_gt (gd.iargs |> List.map fst |> SymSet.of_list) (Option.get gd.body) + in + ({ gd with body = Some gt }, reqs) + + + let request (ctx : GD.context) : GD.context * inline_request list = + ctx + |> List.map snd + |> List.flatten + |> List.map snd + |> List.map request_gd + |> List.fold_left + (fun (ctx', reqs') (gd, reqs) -> (GD.add_context gd ctx', reqs @ reqs')) + ([], []) + + + let fuse ((ctx, reqs) : GD.context * inline_request list) : GD.context = + let rec inject (ret_sym : Sym.t) (lcs : LC.t list) (gt : GT.t) : GT.t = + let (GT (gt_, bt, loc)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ | Map _ -> + GT.let_ + ( 0, + (ret_sym, gt), + List.fold_left + (fun gt_rest lc -> GT.assert_ (lc, gt_rest) loc) + (GT.return_ (IT.sym_ (ret_sym, bt, loc)) loc) + lcs ) + loc + | Pick wgts -> GT.pick_ (List.map_snd (inject ret_sym lcs) wgts) loc + | Asgn ((it_addr, sct), it_val, gt_rest) -> + GT.asgn_ ((it_addr, sct), it_val, inject ret_sym lcs gt_rest) loc + | Let (backtracks, (x, gt_inner), gt_rest) -> + GT.let_ (backtracks, (x, gt_inner), inject ret_sym lcs gt_rest) loc + | Assert (lc, gt_rest) -> GT.assert_ (lc, inject ret_sym lcs gt_rest) loc + | ITE (it_if, gt_then, gt_else) -> + GT.ite_ (it_if, inject ret_sym lcs gt_then, inject ret_sym lcs gt_else) loc + in + let rec aux (reqs : inline_request list) : GD.context = + match reqs with + | { old_name; old_args; ret_sym; new_name; new_args; constraints } :: reqs' -> + let gd = + ctx + |> List.assoc Sym.equal old_name + |> List.assoc (List.equal Sym.equal) (List.map fst old_args) + in + let body = Some (inject ret_sym constraints (Option.get gd.body)) in + let iargs = List.map_snd GenBaseTypes.of_bt (old_args @ new_args) in + (new_name, [ (List.map fst iargs, { gd with name = new_name; iargs; body }) ]) + :: aux reqs' + | [] -> [] + in + aux reqs @ ctx + + + let transform ctx = fuse (request ctx) + end end module PartialEvaluation = struct @@ -3184,4 +3370,17 @@ let optimize = let default = all_passes prog5 |> List.map (fun p -> p.name) |> StringSet.of_list in let passes = Option.value ~default passes in - List.map_snd (List.map_snd (optimize_gen_def prog5 passes)) ctx + ctx + |> List.map_snd + (List.map_snd + (fun ({ filename; recursive; spec; name; iargs; oargs; body } : GD.t) : GD.t -> + { filename; + recursive; + name; + spec; + iargs; + oargs; + body = Option.map (optimize_gen prog5 passes) body + })) + |> Fusion.Recursive.transform + |> List.map_snd (List.map_snd (optimize_gen_def prog5 passes)) From 4088faff0799c2ccf363518c89d2798db49c94f1 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 4 Nov 2024 23:10:20 -0500 Subject: [PATCH 028/148] [CN] Fix `IT.free_vars` for pattern matches (#691) Surprised it took 3 months to catch... --- backend/cn/lib/indexTerms.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/backend/cn/lib/indexTerms.ml b/backend/cn/lib/indexTerms.ml index 3212a1978..cdf1bd561 100644 --- a/backend/cn/lib/indexTerms.ml +++ b/backend/cn/lib/indexTerms.ml @@ -113,7 +113,9 @@ let rec free_vars_bts (it : 'a annot) : BT.t SymMap.t = | [] -> acc | (pat, body) :: cases -> let bound = SymSet.of_list (List.map fst (bound_by_pattern pat)) in - let more = SymMap.filter (fun x _ -> SymSet.mem x bound) (free_vars_bts body) in + let more = + SymMap.filter (fun x _ -> not (SymSet.mem x bound)) (free_vars_bts body) + in aux (SymMap.union (fun _ bt1 bt2 -> From 5cef6738be07a31fc88d4771c245e9ba7ae6900f Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 4 Nov 2024 18:12:19 -0500 Subject: [PATCH 029/148] [CN-Test-Gen] Remove redundant builtin backtracking info --- backend/cn/lib/testGeneration/genCodeGen.ml | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index e32911a4c..bdf137242 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -156,10 +156,15 @@ let rec compile_term (AilEcall (mk_expr (AilEident (Sym.fresh_named name)), List.map mk_expr vars))) in ( [ b ], - [ AilSdeclaration [ (x, Some (mk_expr (AilEcall (mk_expr (AilEident sym), es)))) ]; - macro_call "CN_GEN_CALL_FROM" from_vars; - macro_call "CN_GEN_CALL_TO" to_vars - ], + ([ A.AilSdeclaration + [ (x, Some (mk_expr (AilEcall (mk_expr (AilEident sym), es)))) ] + ] + @ + if GenBuiltins.is_builtin sym then + [] + else + [ macro_call "CN_GEN_CALL_FROM" from_vars; macro_call "CN_GEN_CALL_TO" to_vars ] + ), mk_expr (AilEident x) ) | Asgn { pointer; offset; sct; value; last_var; rest } -> let tmp_sym = Sym.fresh () in From 8e642c678526ef261b542c74b69abcad957f8028 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 4 Nov 2024 21:38:34 -0500 Subject: [PATCH 030/148] [CN-Test-Gen] Fix member indirection duplication --- backend/cn/lib/testGeneration/genOptimize.ml | 71 +++++++++++++------- 1 file changed, 48 insertions(+), 23 deletions(-) diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 929a2b868..859d84e94 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -1267,7 +1267,7 @@ end module MemberIndirection = struct type kind = - | Struct + | Struct of Sym.t | Record let rec replace_memberof_it @@ -1292,7 +1292,7 @@ module MemberIndirection = struct | Struct (tag, xits) -> IT.Struct (tag, List.map_snd repl xits) | StructMember (it', x) -> (match (k, IT.is_sym it') with - | Struct, Some (y, _y_bt) when Sym.equal y sym -> + | Struct _tag, Some (y, _y_bt) when Sym.equal y sym -> IT.Sym (List.assoc Id.equal x dict) | _ -> IT.StructMember (repl it', x)) | StructUpdate ((it_struct, x), it_val) -> @@ -1367,43 +1367,58 @@ module MemberIndirection = struct match gt with | GT ( Let - ( backtracks, - (x, (GT (Return (IT (Struct (_, xits), bt, _)), _, _) as gt_inner)), + ( _backtracks, + (x, GT (Return (IT (Struct (_, xits), bt, loc_it)), _, loc_ret)), gt' ), _, loc ) | GT ( Let - ( backtracks, - (x, (GT (Return (IT (Record xits, bt, _)), _, _) as gt_inner)), + ( _backtracks, + (x, GT (Return (IT (Record xits, bt, loc_it)), _, loc_ret)), gt' ), _, loc ) -> let k = - match bt with Struct _ -> Struct | Record _ -> Record | _ -> failwith __LOC__ + match bt with + | Struct tag -> Struct tag + | Record _ -> Record + | _ -> failwith __LOC__ in - let open Either in - let members = - xits - |> List.map_snd (fun it -> - match IT.is_sym it with - | Some (x, _) -> (Left (), x) - | None -> (Right it, Sym.fresh ())) + let members_to_indirect, members_to_leave = + xits |> List.partition (fun (_, it) -> Option.is_none (IT.is_sym it)) + in + let indirect_map = + List.map_snd (fun _ -> Sym.fresh ()) members_to_indirect + @ List.map + (fun (y, it) -> (y, fst (Option.get (IT.is_sym it)))) + members_to_leave in let gt_main = GT.let_ - ( backtracks, - (x, gt_inner), - replace_memberof_gt k x (List.map_snd snd members) gt' ) + ( 0, + ( x, + GT.return_ + (let members = + indirect_map + |> List.map (fun (y, z) -> + let it = List.assoc Id.equal y xits in + (y, IT.sym_ (z, IT.bt it, IT.loc it))) + in + match k with + | Struct tag -> IT.struct_ (tag, members) loc_it + | Record -> IT.record_ members loc_it) + loc_ret ), + replace_memberof_gt k x indirect_map gt' ) loc in let here = Locations.other __LOC__ in - members - |> List.map snd - |> List.filter_map (fun (info, x) -> - match info with Right it -> Some (x, it) | Left () -> None) + members_to_indirect |> List.fold_left - (fun gt'' (x, it) -> GT.let_ (0, (x, GT.return_ it here), gt'') here) + (fun gt'' (y, it) -> + GT.let_ + (0, (List.assoc Id.equal y indirect_map, GT.return_ it here), gt'') + here) gt_main | _ -> gt in @@ -2280,7 +2295,17 @@ module Reordering = struct in res @ res' @ loop (SymSet.add sym vars) syms' stmts'' | [] -> - assert (List.is_empty stmts'); + if List.non_empty stmts' then + print_endline + (match stmts' with + | [ Assert lc ] -> + Pp.( + LC.free_vars lc + |> SymSet.to_seq + |> List.of_seq + |> separate_map (comma ^^ space) Sym.pp + |> plain) + | _ -> "ss"); res in let syms = get_variable_ordering iargs stmts in From 368d51a1f5f3866de59f2ca791acfcc5e3af5252 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 4 Nov 2024 21:58:22 -0500 Subject: [PATCH 031/148] [CN-Test-Gen] Can set max stack depth for generators To backtrack rather than segfault --- backend/cn/bin/main.ml | 13 ++++- backend/cn/lib/testGeneration/genCodeGen.ml | 10 ++++ backend/cn/lib/testGeneration/specTests.ml | 14 +++-- .../cn/lib/testGeneration/testGenConfig.ml | 8 ++- .../cn/lib/testGeneration/testGenConfig.mli | 5 +- runtime/libcn/include/cn-testing/backtrack.h | 12 ++++- runtime/libcn/include/cn-testing/dsl.h | 22 ++++++-- runtime/libcn/src/cn-testing/backtrack.c | 27 ++++++++++ runtime/libcn/src/cn-testing/rand.c | 9 ++++ runtime/libcn/src/cn-testing/test.c | 8 ++- tests/cn-test-gen/src/sorted_list.pass.c | 52 +++++++++++++++++++ 11 files changed, 163 insertions(+), 17 deletions(-) create mode 100644 tests/cn-test-gen/src/sorted_list.pass.c diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index d2f66ca96..3d3e0abbb 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -462,6 +462,7 @@ let run_tests interactive until_timeout exit_fast + max_stack_depth = (* flags *) Cerb_debug.debug_level := debug_level; @@ -513,7 +514,8 @@ let run_tests logging_level; interactive; until_timeout; - exit_fast + exit_fast; + max_stack_depth } in TestGeneration.run @@ -958,6 +960,14 @@ module Testing_flags = struct let test_exit_fast = let doc = "Stop testing upon finding the first failure" in Arg.(value & flag & info [ "exit-fast" ] ~doc) + + + let test_max_stack_depth = + let doc = "Maximum stack depth for generators" in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.max_stack_depth + & info [ "max-stack-depth" ] ~doc) end let testing_cmd = @@ -988,6 +998,7 @@ let testing_cmd = $ Testing_flags.interactive_testing $ Testing_flags.test_until_timeout $ Testing_flags.test_exit_fast + $ Testing_flags.test_max_stack_depth in let doc = "Generates RapidCheck tests for all functions in [FILE] with CN specifications.\n\ diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index bdf137242..bc0df5b62 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -450,6 +450,16 @@ let compile_gen_def mk_stmt ([ s1 ] @ s2 + @ A. + [ AilSexpr + (mk_expr + (AilEcall + ( mk_expr + (AilEident + (Sym.fresh_named + "cn_gen_backtrack_decrement_depth")), + [] ))) + ] @ A. [ AilSreturn (mk_expr diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 909b1be8a..5011b447e 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -450,11 +450,15 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = @ (match Config.is_until_timeout () with | Some timeout -> [ "--until-timeout"; string_of_int timeout ] | None -> []) - @ - if Config.is_exit_fast () then - [ "--exit-fast" ] - else - []) + @ (if Config.is_exit_fast () then + [ "--exit-fast" ] + else + []) + @ (Config.has_max_stack_depth () + |> Option.map (fun max_stack_depth -> + [ "--max-stack-depth"; string_of_int max_stack_depth ]) + |> Option.to_list + |> List.flatten)) in string "if" ^^ space diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index edb4f6781..ed2383917 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -9,7 +9,8 @@ type t = logging_level : int option; interactive : bool; until_timeout : int option; - exit_fast : bool + exit_fast : bool; + max_stack_depth : int option } let default = @@ -21,7 +22,8 @@ let default = logging_level = None; interactive = false; until_timeout = None; - exit_fast = false + exit_fast = false; + max_stack_depth = None } @@ -46,3 +48,5 @@ let is_interactive () = !instance.interactive let is_until_timeout () = !instance.until_timeout let is_exit_fast () = !instance.exit_fast + +let has_max_stack_depth () = !instance.max_stack_depth diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 4b9918e4e..7a7a20aee 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -9,7 +9,8 @@ type t = logging_level : int option; interactive : bool; until_timeout : int option; - exit_fast : bool + exit_fast : bool; + max_stack_depth : int option } val default : t @@ -33,3 +34,5 @@ val is_interactive : unit -> bool val is_until_timeout : unit -> int option val is_exit_fast : unit -> bool + +val has_max_stack_depth : unit -> int option diff --git a/runtime/libcn/include/cn-testing/backtrack.h b/runtime/libcn/include/cn-testing/backtrack.h index 1dcbf0e1c..ed55a6d69 100644 --- a/runtime/libcn/include/cn-testing/backtrack.h +++ b/runtime/libcn/include/cn-testing/backtrack.h @@ -2,11 +2,19 @@ #define CN_GEN_BACKTRACK_H #include +#include + +uint16_t cn_gen_backtrack_depth(); +uint16_t cn_gen_backtrack_max_depth(); +void cn_gen_backtrack_set_max_depth(uint16_t msd); +void cn_gen_backtrack_increment_depth(); +void cn_gen_backtrack_decrement_depth(); enum cn_gen_backtrack_request { CN_GEN_BACKTRACK_NONE, CN_GEN_BACKTRACK_ASSERT, - CN_GEN_BACKTRACK_ALLOC + CN_GEN_BACKTRACK_ALLOC, + CN_GEN_BACKTRACK_DEPTH }; enum cn_gen_backtrack_request cn_gen_backtrack_type(void); @@ -21,6 +29,8 @@ void cn_gen_backtrack_relevant_add_many(char* toAdd[]); int cn_gen_backtrack_relevant_contains(char* varname); +void cn_gen_backtrack_depth_exceeded(); + /** * @brief Remaps a relevant variable * diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index e8c29acf5..4ee05316f 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -10,8 +10,15 @@ #define CN_GEN_INIT() \ if (0) { \ cn_label_bennet_backtrack: \ + cn_gen_backtrack_decrement_depth(); \ return NULL; \ - } + } \ + if (cn_gen_backtrack_depth() == cn_gen_backtrack_max_depth()) { \ + cn_gen_backtrack_depth_exceeded(); \ + goto cn_label_bennet_backtrack; \ + } else { \ + cn_gen_backtrack_increment_depth(); \ + } \ #define CN_GEN_UNIFORM(ty, sz) cn_gen_uniform_##ty(sz) @@ -70,9 +77,9 @@ void *var##_alloc_checkpoint = cn_gen_alloc_save(); \ void *var##_ownership_checkpoint = cn_gen_ownership_save(); - #define CN_GEN_LET_BODY(ty, var, gen) \ - ty* var = gen; + ty* var = gen; \ + cn_gen_rand_checkpoint var##_rand_checkpoint = cn_gen_rand_save(); #define CN_GEN_LET_END(backtracks, var, last_var, ...) \ if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ @@ -80,13 +87,17 @@ free_after(var##_checkpoint); \ cn_gen_alloc_restore(var##_alloc_checkpoint); \ cn_gen_ownership_restore(var##_ownership_checkpoint); \ + if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ALLOC) { \ + cn_gen_rand_restore(var##_rand_checkpoint); \ + } \ if (cn_gen_backtrack_relevant_contains((char*)#var)) { \ char *toAdd[] = { __VA_ARGS__ }; \ cn_gen_backtrack_relevant_add_many(toAdd); \ if (var##_backtracks <= 0) { \ goto cn_label_##last_var##_backtrack; \ } \ - if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ASSERT) { \ + if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ASSERT \ + || cn_gen_backtrack_type() == CN_GEN_BACKTRACK_DEPTH) { \ var##_backtracks--; \ cn_gen_backtrack_reset(); \ } else if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ALLOC) { \ @@ -155,7 +166,8 @@ free_after(tmp##_checkpoint); \ cn_gen_alloc_restore(tmp##_alloc_checkpoint); \ cn_gen_ownership_restore(tmp##_ownership_checkpoint); \ - if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ASSERT \ + if ((cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ASSERT \ + || cn_gen_backtrack_type() == CN_GEN_BACKTRACK_DEPTH) \ && tmp##_urn->size != 0) { \ cn_gen_backtrack_reset(); \ goto cn_label_##tmp##_gen; \ diff --git a/runtime/libcn/src/cn-testing/backtrack.c b/runtime/libcn/src/cn-testing/backtrack.c index a90794f69..a7db8aac2 100644 --- a/runtime/libcn/src/cn-testing/backtrack.c +++ b/runtime/libcn/src/cn-testing/backtrack.c @@ -2,6 +2,29 @@ #include +static uint16_t stack_depth = 0; +static uint16_t max_stack_depth = UINT8_MAX; + +uint16_t cn_gen_backtrack_depth() { + return stack_depth; +} + +uint16_t cn_gen_backtrack_max_depth() { + return max_stack_depth; +} + +void cn_gen_backtrack_set_max_depth(uint16_t msd) { + max_stack_depth = msd; +} + +void cn_gen_backtrack_increment_depth() { + stack_depth++; +} + +void cn_gen_backtrack_decrement_depth() { + stack_depth--; +} + static enum cn_gen_backtrack_request type = CN_GEN_BACKTRACK_NONE; @@ -27,6 +50,10 @@ void cn_gen_backtrack_assert_failure(void) { type = CN_GEN_BACKTRACK_ASSERT; } +void cn_gen_backtrack_depth_exceeded() { + type = CN_GEN_BACKTRACK_DEPTH; +} + void cn_gen_backtrack_relevant_add(char* varname) { struct name_list* new_node = (struct name_list*)malloc(sizeof(struct name_list)); *new_node = (struct name_list){ diff --git a/runtime/libcn/src/cn-testing/rand.c b/runtime/libcn/src/cn-testing/rand.c index 85a8c711c..596c17997 100644 --- a/runtime/libcn/src/cn-testing/rand.c +++ b/runtime/libcn/src/cn-testing/rand.c @@ -167,7 +167,16 @@ void cn_gen_rand_restore(cn_gen_rand_checkpoint checkpoint) { choice_history = checkpoint; } +void free_list(struct choice_list* curr) { + while (curr != NULL) { + struct choice_list* tmp = curr; + curr = curr->next; + free(tmp); + } +} + void cn_gen_rand_replace(cn_gen_rand_checkpoint checkpoint) { cn_gen_rand_restore(checkpoint); + free_list(choice_history->next); choice_history->next = 0; } diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index 57e12e26a..1035e0ff7 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -12,6 +12,7 @@ #include #include #include +#include struct cn_test_case { char* suite; @@ -76,7 +77,7 @@ int cn_test_main(int argc, char* argv[]) { i++; } else if (strcmp("--null-in-every", arg) == 0) { - set_null_in_every(strtol(argv[i + 1], NULL, 16)); + set_null_in_every(strtol(argv[i + 1], NULL, 10)); i++; } else if (strcmp("--until-timeout", arg) == 0) { @@ -86,6 +87,10 @@ int cn_test_main(int argc, char* argv[]) { else if (strcmp("--exit-fast", arg) == 0) { exit_fast = 1; } + else if (strcmp("--max-stack-depth", arg) == 0) { + cn_gen_backtrack_set_max_depth(strtoul(argv[i + 1], NULL, 10)); + i++; + } } if (interactive) { @@ -114,7 +119,6 @@ int cn_test_main(int argc, char* argv[]) { struct cn_test_case* test_case = &test_cases[i]; print_test_info(test_case->suite, test_case->name, 0, 0); - fflush(stdout); checkpoints[i] = cn_gen_rand_save(); enum cn_test_result result = test_case->func(1); if (!(results[i] == CN_TEST_PASS && result == CN_TEST_GEN_FAIL)) { diff --git a/tests/cn-test-gen/src/sorted_list.pass.c b/tests/cn-test-gen/src/sorted_list.pass.c new file mode 100644 index 000000000..62dd72263 --- /dev/null +++ b/tests/cn-test-gen/src/sorted_list.pass.c @@ -0,0 +1,52 @@ +// Sorted list + +struct List +{ + int value; + struct List* next; +}; + +/*@ +datatype IntList { + Nil {}, + Cons { i32 head, IntList tail } +} + +function (boolean) validCons(i32 head, IntList tail) { + match tail { + Nil {} => { true } + Cons { head: next, tail: _ } => { head <= next } + } +} + +predicate IntList ListSegment(pointer from, pointer to) { + if (ptr_eq(from,to)) { + return Nil {}; + } else { + take head = Owned(from); + take tail = ListSegment(head.next, to); + assert(validCons(head.value,tail)); + return Cons { head: head.value, tail: tail }; + } +} +@*/ + + +// This is a valid spec, even though to verify with CN we'd need a loop invariant. +int sum(struct List* xs) +/*@ + requires + take l1 = ListSegment(xs,NULL); + ensures + take l2 = ListSegment(xs,NULL); + l1 == l2; + true; +@*/ +{ + int result = 0; + while(xs) { + result += xs->value; + xs = xs->next; + } + return result; +} From 0be8fe9e4c4b6e33fa71dbc95072b79da4e66322 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 6 Nov 2024 12:28:11 +0000 Subject: [PATCH 032/148] CN Exec: Remove coq install from CI --- .github/workflows/ci-runtime.yml | 8 -------- 1 file changed, 8 deletions(-) diff --git a/.github/workflows/ci-runtime.yml b/.github/workflows/ci-runtime.yml index b193008a4..16c59378f 100644 --- a/.github/workflows/ci-runtime.yml +++ b/.github/workflows/ci-runtime.yml @@ -46,14 +46,6 @@ jobs: run: | opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} opam install --deps-only --yes ./cerberus-lib.opam - opam switch create with_coq ${{ matrix.version }} - eval $(opam env --switch=with_coq) - opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released - opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git - opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git - opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git - opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - name: Save cached opam if: steps.cache-opam-restore.outputs.cache-hit != 'true' From f82b33c04314b2746e2a622684c3ef244cd95fe2 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 6 Nov 2024 12:36:55 +0000 Subject: [PATCH 033/148] Split up CIs --- .github/workflows/ci-cheri.yml | 76 ++++++++++++ .../{ci-bench.yml => ci-cn-bench.yml} | 11 +- ...{ci-runtime.yml => ci-cn-spec-testing.yml} | 10 +- .github/workflows/ci-cn.yml | 111 ++++++++++++++++++ .github/workflows/ci.yml | 85 -------------- 5 files changed, 197 insertions(+), 96 deletions(-) create mode 100644 .github/workflows/ci-cheri.yml rename .github/workflows/{ci-bench.yml => ci-cn-bench.yml} (82%) rename .github/workflows/{ci-runtime.yml => ci-cn-spec-testing.yml} (91%) create mode 100644 .github/workflows/ci-cn.yml diff --git a/.github/workflows/ci-cheri.yml b/.github/workflows/ci-cheri.yml new file mode 100644 index 000000000..da46b4174 --- /dev/null +++ b/.github/workflows/ci-cheri.yml @@ -0,0 +1,76 @@ +name: CHERI + +on: + pull_request: + push: + branches: + - master + - cheri-tests + +env: + CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn:release + +# cancel in-progress job when a new push is performed +concurrency: + group: ci-${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + +jobs: + build: + strategy: + matrix: + # version: [4.12.0, 4.14.1] + version: [4.14.1] + + + runs-on: ubuntu-22.04 + + steps: + - uses: actions/checkout@v3 + + - name: System dependencies (ubuntu) + run: | + sudo apt install build-essential libgmp-dev opam + + - name: Restore cached opam + id: cache-opam-restore + uses: actions/cache/restore@v4 + with: + path: ~/.opam + key: ${{ matrix.version }} + + - name: Setup opam + if: steps.cache-opam-restore.outputs.cache-hit != 'true' + run: | + eval $(opam env --switch=with_coq) + opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released + opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git + opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git + opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad + opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git + opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam + + - name: Save cached opam + if: steps.cache-opam-restore.outputs.cache-hit != 'true' + id: cache-opam-save + uses: actions/cache/save@v4 + with: + path: ~/.opam + key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + + - name: Install Cerberus-CHERI + if: ${{ matrix.version == '4.14.1' }} + run: | + opam switch with_coq + eval $(opam env --switch=with_coq) + opam pin --yes --no-action add cerberus-lib . + opam pin --yes --no-action add cerberus-cheri . + opam install --yes cerberus-cheri + + - name: Run Cerberus-CHERI CI tests + if: ${{ matrix.version == '4.14.1' }} + run: | + opam switch with_coq + eval $(opam env --switch=with_coq) + cd tests; USE_OPAM='' ./run-cheri.sh + cd .. diff --git a/.github/workflows/ci-bench.yml b/.github/workflows/ci-cn-bench.yml similarity index 82% rename from .github/workflows/ci-bench.yml rename to .github/workflows/ci-cn-bench.yml index 101931c54..4acda0fcd 100644 --- a/.github/workflows/ci-bench.yml +++ b/.github/workflows/ci-cn-bench.yml @@ -1,4 +1,4 @@ -name: CI Benchmarks +name: CN Benchmarks on: push: @@ -35,7 +35,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt install build-essential libgmp-dev z3 opam cmake jq + sudo apt install build-essential libgmp-dev z3 opam jq - name: Restore cached opam id: cache-opam-restore @@ -50,13 +50,6 @@ jobs: opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} opam install --deps-only --yes ./cerberus-lib.opam opam switch create with_coq ${{ matrix.version }} - eval $(opam env --switch=with_coq) - opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released - opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git - opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git - opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git - opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - name: Save cached opam if: steps.cache-opam-restore.outputs.cache-hit != 'true' diff --git a/.github/workflows/ci-runtime.yml b/.github/workflows/ci-cn-spec-testing.yml similarity index 91% rename from .github/workflows/ci-runtime.yml rename to .github/workflows/ci-cn-spec-testing.yml index 16c59378f..0be117ca0 100644 --- a/.github/workflows/ci-runtime.yml +++ b/.github/workflows/ci-cn-spec-testing.yml @@ -1,11 +1,10 @@ -name: CI (CN runtime checks) +name: CN Spec Testing on: pull_request: push: branches: - master - - cheri-tests env: CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn:release @@ -89,3 +88,10 @@ jobs: eval $(opam env --switch=${{ matrix.version }}) cd cn-tutorial; ./runtime-test.sh cd .. + + - name: Run CN-Test-Gen CI tests + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + cd tests; USE_OPAM='' ./run-cn-test-gen.sh + diff --git a/.github/workflows/ci-cn.yml b/.github/workflows/ci-cn.yml new file mode 100644 index 000000000..98ced7836 --- /dev/null +++ b/.github/workflows/ci-cn.yml @@ -0,0 +1,111 @@ +name: CN Proof + +on: + pull_request: + push: + branches: + - master + +env: + CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn:release + +# cancel in-progress job when a new push is performed +concurrency: + group: ci-${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + +jobs: + build: + strategy: + matrix: + # version: [4.12.0, 4.14.1] + version: [4.14.1] + + + runs-on: ubuntu-22.04 + + steps: + - uses: actions/checkout@v3 + + - name: System dependencies (ubuntu) + run: | + sudo apt install build-essential libgmp-dev z3 opam + + - name: Restore cached opam + id: cache-opam-restore + uses: actions/cache/restore@v4 + with: + path: ~/.opam + key: ${{ matrix.version }} + + - name: Setup opam + if: steps.cache-opam-restore.outputs.cache-hit != 'true' + run: | + opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} + opam install --deps-only --yes ./cerberus-lib.opam + + - name: Save cached opam + if: steps.cache-opam-restore.outputs.cache-hit != 'true' + id: cache-opam-save + uses: actions/cache/save@v4 + with: + path: ~/.opam + key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + + - name: Install Cerberus + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + opam pin --yes --no-action add cerberus-lib . + opam pin --yes --no-action add cerberus . + opam install --yes cerberus + + - name: Download cvc5 release + uses: robinraju/release-downloader@v1 + with: + repository: cvc5/cvc5 + tag: cvc5-1.2.0 + fileName: cvc5-Linux-x86_64-static.zip + + - name: Unzip and install cvc5 + run: | + unzip cvc5-Linux-x86_64-static.zip + chmod +x cvc5-Linux-x86_64-static/bin/cvc5 + sudo cp cvc5-Linux-x86_64-static/bin/cvc5 /usr/local/bin/ + + - name: Install CN + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + opam pin --yes --no-action add cn . + opam install --yes cn ocamlformat.0.26.2 + + - name: Check CN code formatting + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + USE_OPAM='' cd backend/cn && dune build @fmt + + - name: Checkout cn-tutorial + uses: actions/checkout@v4 + with: + repository: rems-project/cn-tutorial + path: cn-tutorial + + - name: Run CN CI tests + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + cd tests; USE_OPAM='' ./run-cn.sh + + - name: Run CN Tutorial CI tests + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + USE_OPAM='' tests/run-cn-tutorial-ci.sh cn-tutorial + + - name: Run CN VIP CI tests + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + cd tests; USE_OPAM='' ./run-cn-vip.sh diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index bc25e9fa7..481e5a1ee 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -44,14 +44,6 @@ jobs: run: | opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} opam install --deps-only --yes ./cerberus-lib.opam - opam switch create with_coq ${{ matrix.version }} - eval $(opam env --switch=with_coq) - opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released - opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git - opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git - opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git - opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - name: Save cached opam if: steps.cache-opam-restore.outputs.cache-hit != 'true' @@ -74,80 +66,3 @@ jobs: opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) cd tests; USE_OPAM='' ./run-ci.sh - cd .. - - - name: Download cvc5 release - uses: robinraju/release-downloader@v1 - with: - repository: cvc5/cvc5 - tag: cvc5-1.2.0 - fileName: cvc5-Linux-x86_64-static.zip - - - name: Unzip and install cvc5 - run: | - unzip cvc5-Linux-x86_64-static.zip - chmod +x cvc5-Linux-x86_64-static/bin/cvc5 - sudo cp cvc5-Linux-x86_64-static/bin/cvc5 /usr/local/bin/ - - - name: Install CN - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - opam pin --yes --no-action add cn . - opam install --yes cn ocamlformat.0.26.2 - - - name: Check CN code formatting - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - USE_OPAM='' cd backend/cn && dune build @fmt - - - name: Checkout cn-tutorial - uses: actions/checkout@v4 - with: - repository: rems-project/cn-tutorial - path: cn-tutorial - - - name: Run CN CI tests - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-cn.sh - - - name: Run CN Tutorial CI tests - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - USE_OPAM='' tests/run-cn-tutorial-ci.sh cn-tutorial - - - name: Run CN-Test-Gen CI tests - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-cn-test-gen.sh - cd .. - - - name: Run CN VIP CI tests - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-cn-vip.sh - cd .. - - - - name: Install Cerberus-CHERI - if: ${{ matrix.version == '4.14.1' }} - run: | - opam switch with_coq - eval $(opam env --switch=with_coq) - opam pin --yes --no-action add cerberus-lib . - opam pin --yes --no-action add cerberus-cheri . - opam install --yes cerberus-cheri - - - name: Run Cerberus-CHERI CI tests - if: ${{ matrix.version == '4.14.1' }} - run: | - opam switch with_coq - eval $(opam env --switch=with_coq) - cd tests; USE_OPAM='' ./run-cheri.sh - cd .. From 84d21f388def0fe34fc356a7741fabe1c6481156 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Wed, 6 Nov 2024 12:55:06 -0500 Subject: [PATCH 034/148] [CN-Exec/CN-Test-Gen] Generalize failure handling (#699) --- runtime/libcn/include/cn-executable/utils.h | 15 ++++++++-- runtime/libcn/include/cn-testing/test.h | 31 ++++++++++--------- runtime/libcn/src/cn-executable/alloc.c | 5 ++-- runtime/libcn/src/cn-executable/utils.c | 33 ++++++++++++++------- runtime/libcn/src/cn-testing/test.c | 2 +- 5 files changed, 55 insertions(+), 31 deletions(-) diff --git a/runtime/libcn/include/cn-executable/utils.h b/runtime/libcn/include/cn-executable/utils.h index 1f18c357a..80b228b25 100644 --- a/runtime/libcn/include/cn-executable/utils.h +++ b/runtime/libcn/include/cn-executable/utils.h @@ -138,9 +138,18 @@ void cn_free_sized(void*, size_t len); void cn_print_nr_u64(int i, unsigned long u) ; void cn_print_u64(const char *str, unsigned long u) ; -/* cn_exit callbacks */ -void set_cn_exit_cb(void (*callback)(void)); -void reset_cn_exit_cb(void); +/* cn_failure callbacks */ +enum cn_failure_mode { + CN_FAILURE_ASSERT = 1, + CN_FAILURE_CHECK_OWNERSHIP, + CN_FAILURE_OWNERSHIP_LEAK, + CN_FAILURE_ALLOC +}; + +typedef void (*cn_failure_callback)(enum cn_failure_mode); +void set_cn_failure_cb(cn_failure_callback callback); +void reset_cn_failure_cb(void); +void cn_failure(enum cn_failure_mode mode); /* Conversion functions */ diff --git a/runtime/libcn/include/cn-testing/test.h b/runtime/libcn/include/cn-testing/test.h index 7af5a3912..9691d6df4 100644 --- a/runtime/libcn/include/cn-testing/test.h +++ b/runtime/libcn/include/cn-testing/test.h @@ -22,7 +22,7 @@ void print_test_info(char* suite, char* name, int tests, int discards); if (setjmp(buf_##Name)) { \ return CN_TEST_FAIL; \ } \ - set_cn_exit_cb(&cn_test_##Name##_fail); \ + set_cn_failure_cb(&cn_test_##Name##_fail); \ \ CN_TEST_INIT(); \ Name(); \ @@ -33,39 +33,42 @@ void print_test_info(char* suite, char* name, int tests, int discards); #define CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Suite, Name, Samples, Init, ...) \ static jmp_buf buf_##Name; \ \ - void cn_test_##Name##_fail () { \ - longjmp(buf_##Name, 1); \ + void cn_test_##Name##_fail (enum cn_failure_mode mode) { \ + longjmp(buf_##Name, mode); \ } \ \ enum cn_test_result cn_test_##Name (int printing) { \ - if (setjmp(buf_##Name)) { \ - return CN_TEST_FAIL; \ - } \ - set_cn_exit_cb(&cn_test_##Name##_fail); \ - \ cn_gen_rand_checkpoint checkpoint = cn_gen_rand_save(); \ int i = 0, d = 0; \ + switch (setjmp(buf_##Name)) { \ + case CN_FAILURE_ASSERT: \ + case CN_FAILURE_CHECK_OWNERSHIP: \ + case CN_FAILURE_OWNERSHIP_LEAK: \ + return CN_TEST_FAIL; \ + case CN_FAILURE_ALLOC: \ + d++; \ + break; \ + } \ + set_cn_failure_cb(&cn_test_##Name##_fail); \ for (; i < Samples; i++) { \ if (printing) { \ printf("\r"); \ print_test_info(#Suite, #Name, i, d); \ } \ + if (d == 10 * Samples) { \ + return CN_TEST_GEN_FAIL; \ + } \ + cn_gen_rand_replace(checkpoint); \ CN_TEST_INIT(); \ struct cn_gen_##Name##_record *res = cn_gen_##Name(); \ if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ i--; \ d++; \ - if (d == 10 * Samples) { \ - printf("\r"); \ - print_test_info(#Suite, #Name, i + 1, d); \ - return CN_TEST_GEN_FAIL; \ - } \ continue; \ } \ assume_##Name(__VA_ARGS__); \ Init(res); \ Name(__VA_ARGS__); \ - cn_gen_rand_replace(checkpoint); \ } \ \ if (printing) { \ diff --git a/runtime/libcn/src/cn-executable/alloc.c b/runtime/libcn/src/cn-executable/alloc.c index 3ca5be534..81e01fe2d 100644 --- a/runtime/libcn/src/cn-executable/alloc.c +++ b/runtime/libcn/src/cn-executable/alloc.c @@ -3,6 +3,7 @@ #include #include +#include // #define foo(x)\ // [ x ] = #x @@ -44,8 +45,8 @@ void *alloc_(long nbytes, const char *str, int line) { // printf("Alloc called: %s:%d\n", str, line); void *res = curr; if ((char *) curr + nbytes - buf > MEM_SIZE) { - printf("Out of memory! %lu\n", count); - exit(1); + cn_failure(CN_FAILURE_ALLOC); + return NULL; } count++; curr += nbytes; diff --git a/runtime/libcn/src/cn-executable/utils.c b/runtime/libcn/src/cn-executable/utils.c index 9e04e4f0c..62125092d 100644 --- a/runtime/libcn/src/cn-executable/utils.c +++ b/runtime/libcn/src/cn-executable/utils.c @@ -27,18 +27,29 @@ enum cn_logging_level set_cn_logging_level(enum cn_logging_level new_level) { return old_level; } -void cn_exit_aux(void) { - exit(SIGABRT); +void cn_failure_default(enum cn_failure_mode mode) { + switch (mode) { + case CN_FAILURE_ALLOC: + printf("Out of memory!"); + case CN_FAILURE_ASSERT: + case CN_FAILURE_CHECK_OWNERSHIP: + case CN_FAILURE_OWNERSHIP_LEAK: + exit(SIGABRT); + } } -void static (*cn_exit)(void) = &cn_exit_aux; +static cn_failure_callback cn_failure_aux = &cn_failure_default; -void set_cn_exit_cb(void (*callback)(void)) { - cn_exit = callback; +void cn_failure(enum cn_failure_mode mode) { + cn_failure_aux(mode); } -void reset_cn_exit_cb(void) { - cn_exit = &cn_exit_aux; +void set_cn_failure_cb(cn_failure_callback callback) { + cn_failure_aux = callback; +} + +void reset_cn_failure_cb(void) { + cn_failure_aux = &cn_failure_default; } void print_error_msg_info(struct cn_error_message_info *info) { @@ -54,7 +65,7 @@ void print_error_msg_info(struct cn_error_message_info *info) { } else { cn_printf(CN_LOGGING_ERROR, "Internal error: no error_msg_info available."); - cn_exit_aux(); + exit(SIGABRT); } } @@ -74,7 +85,7 @@ void cn_assert(cn_bool *cn_b) { if (!(cn_b->val)) { print_error_msg_info(error_msg_info); cn_printf(CN_LOGGING_ERROR, "CN assertion failed."); - cn_exit(); + cn_failure(CN_FAILURE_ASSERT); } } @@ -161,7 +172,7 @@ void ghost_stack_depth_decr(void) { if (*depth > cn_stack_depth) { print_error_msg_info(error_msg_info); cn_printf(CN_LOGGING_ERROR, "Leak check failed, ownership leaked for pointer "FMT_PTR"\n", *key); - cn_exit(); + cn_failure(CN_FAILURE_OWNERSHIP_LEAK); // cn_printf(CN_LOGGING_INFO, FMT_PTR_2 " (%d),", *key, *depth); } } @@ -277,7 +288,7 @@ void c_ownership_check(char *access_kind, uintptr_t generic_c_ptr, int offset, s cn_printf(CN_LOGGING_ERROR, " ==> "FMT_PTR"[%d] ("FMT_PTR") not owned at expected function call stack depth %ld\n", generic_c_ptr, i, (uintptr_t)((char*)generic_c_ptr + i), expected_stack_depth); cn_printf(CN_LOGGING_ERROR, " ==> (owned at stack depth: %d)\n", curr_depth); } - cn_exit(); + cn_failure(CN_FAILURE_CHECK_OWNERSHIP); } } // cn_printf(CN_LOGGING_INFO, "\n"); diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index 1035e0ff7..487ccb389 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -228,7 +228,7 @@ int cn_test_main(int argc, char* argv[]) { cn_gen_rand_restore(checkpoints[mapToCase[testcase - 1]]); set_cn_logging_level(CN_LOGGING_INFO); - reset_cn_exit_cb(); + reset_cn_failure_cb(); // raise(SIGTRAP); // Trigger breakpoint test_cases[mapToCase[testcase - 1]].func(0); } From bddba229bf84f52ac748ea9db3f26d718e328395 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 5 Nov 2024 16:54:56 +0000 Subject: [PATCH 035/148] CN VIP: Add support for memcpy & proxy This commit hooks into an existing place for assigning function types to proxy functions. It assumes that memcpy's type is expressible in CN, which is true-ish for now, but may not remain so if we want to support round-trip for pointers without provenance in byte values, and thus need a "special type" or more arbitrary set of operations on the typing context to support. It also removes some legacy/mostly unused code around partial evaluation. --- backend/cn/bin/main.ml | 41 +----- backend/cn/lib/cLogicalFuns.ml | 33 ++--- backend/cn/lib/check.ml | 134 ++++++++++++++----- backend/cn/lib/setup.ml | 7 - backend/cn/lib/setup.mli | 2 - tests/cn_vip_testsuite/cn_lemmas.h | 17 --- tests/cn_vip_testsuite/pointer_copy_memcpy.c | 2 +- tests/run-cn-vip.sh | 5 - 8 files changed, 123 insertions(+), 118 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 3d3e0abbb..32e501c9b 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -43,14 +43,7 @@ end open Log -let frontend - ~macros - ~incl_dirs - ~incl_files - astprints - ~do_peval - ~filename - ~magic_comment_char_dollar +let frontend ~macros ~incl_dirs ~incl_files astprints ~filename ~magic_comment_char_dollar = let open CF in Cerb_global.set_cerb_conf @@ -67,7 +60,6 @@ let frontend Switches.set ([ "inner_arg_temps"; "at_magic_comments" ] @ if magic_comment_char_dollar then [ "magic_comment_char_dollar" ] else []); - Core_peval.config_unfold_stdlib := Sym.has_id_with Setup.unfold_stdlib_name; let@ stdlib = load_core_stdlib () in let@ impl = load_core_impl stdlib impl_name in let conf = Setup.conf macros incl_dirs incl_files astprints in @@ -90,14 +82,12 @@ let frontend let markers_env, ail_prog = Option.get ail_prog_opt in Tags.set_tagDefs prog0.Core.tagDefs; let prog1 = Remove_unspecs.rewrite_file prog0 in - let prog2 = if do_peval then Core_peval.rewrite_file prog1 else prog1 in - let prog3 = Milicore.core_to_micore__file Locations.update prog2 in - let prog4 = Milicore_label_inline.rewrite_file prog3 in + let prog2 = Milicore.core_to_micore__file Locations.update prog1 in + let prog3 = Milicore_label_inline.rewrite_file prog2 in let statement_locs = CStatements.search (snd ail_prog) in print_log_file ("original", CORE prog0); print_log_file ("without_unspec", CORE prog1); - print_log_file ("after_peval", CORE prog2); - return (prog4, (markers_env, ail_prog), statement_locs) + return (prog3, (markers_env, ail_prog), statement_locs) let handle_frontend_error = function @@ -133,7 +123,6 @@ let with_well_formedness_check ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar ~(* Callbacks *) @@ -146,14 +135,13 @@ let with_well_formedness_check unit Resultat.t) = check_input_file filename; - let prog4, (markers_env, ail_prog), statement_locs = + let prog, (markers_env, ail_prog), statement_locs = handle_frontend_error (frontend ~macros ~incl_dirs ~incl_files astprints - ~do_peval:use_peval ~filename ~magic_comment_char_dollar) in @@ -170,7 +158,7 @@ let with_well_formedness_check Core_to_mucore.normalise_file ~inherit_loc:(not no_inherit_loc) (markers_env, snd ail_prog) - prog4 + prog in print_log_file ("mucore", MUCORE prog5); let paused = @@ -244,7 +232,6 @@ let well_formed csv_times log_times astprints - use_peval no_inherit_loc magic_comment_char_dollar = @@ -256,7 +243,6 @@ let well_formed ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) @@ -292,7 +278,6 @@ let verify astprints dont_use_vip no_use_ity - use_peval fail_fast quiet no_inherit_loc @@ -332,7 +317,6 @@ let verify ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) @@ -377,7 +361,6 @@ let generate_executable_specs astprints dont_use_vip no_use_ity - use_peval fail_fast no_inherit_loc magic_comment_char_dollar @@ -413,7 +396,6 @@ let generate_executable_specs ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) @@ -445,7 +427,6 @@ let run_tests csv_times log_times astprints - use_peval no_inherit_loc magic_comment_char_dollar (* Executable spec *) @@ -481,7 +462,6 @@ let run_tests ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) ~handle_error @@ -641,11 +621,6 @@ module Common_flags = struct Arg.(value & flag & info [ "no-use-ity" ] ~doc) - let use_peval = - let doc = "(this switch should go away) run the Core partial evaluation phase" in - Arg.(value & flag & info [ "use-peval" ] ~doc) - - let no_inherit_loc = let doc = "debugging: stop mucore terms inheriting location information from parents" @@ -816,7 +791,6 @@ let wf_cmd = $ Common_flags.csv_times $ Common_flags.log_times $ Common_flags.astprints - $ Common_flags.use_peval $ Common_flags.no_inherit_loc $ Common_flags.magic_comment_char_dollar in @@ -864,7 +838,6 @@ let verify_t : unit Term.t = $ Common_flags.astprints $ Verify_flags.dont_use_vip $ Common_flags.no_use_ity - $ Common_flags.use_peval $ Verify_flags.fail_fast $ Verify_flags.quiet $ Common_flags.no_inherit_loc @@ -983,7 +956,6 @@ let testing_cmd = $ Common_flags.csv_times $ Common_flags.log_times $ Common_flags.astprints - $ Common_flags.use_peval $ Common_flags.no_inherit_loc $ Common_flags.magic_comment_char_dollar $ Executable_spec_flags.without_ownership_checking @@ -1034,7 +1006,6 @@ let instrument_cmd = $ Common_flags.astprints $ Verify_flags.dont_use_vip $ Common_flags.no_use_ity - $ Common_flags.use_peval $ Verify_flags.fail_fast $ Common_flags.no_inherit_loc $ Common_flags.magic_comment_char_dollar diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index fa19a6350..980af1821 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -545,22 +545,23 @@ let rec symb_exec_expr ctxt state_vars expr = let loc, l_sym = SymMap.find nm ctxt.c_fun_pred_map in let@ def = get_logical_function_def loc l_sym in rcval (IT.apply_ l_sym args_its def.LogicalFunctions.return_bt loc) state) - else if Sym.has_id_with Setup.unfold_stdlib_name nm then ( - let s = Option.get (Sym.has_id nm) in - let wrap_int x = IT.wrapI_ (signed_int_ity, x) in - if String.equal s "ctz_proxy" then - rcval - (wrap_int (IT.arith_unop Terms.BW_CTZ_NoSMT (List.hd args_its) loc) loc) - state - else if List.exists (String.equal s) [ "ffs_proxy"; "ffsl_proxy"; "ffsll_proxy" ] - then - rcval - (wrap_int (IT.arith_unop Terms.BW_FFS_NoSMT (List.hd args_its) loc) loc) - state - else - failwith ("unknown stdlib function: " ^ s)) - else - fail_fun_it "not a function with a pure/logical interpretation" + else ( + let bail = fail_fun_it "not a function with a pure/logical interpretation" in + match Sym.has_id nm with + | None -> bail + | Some s -> + let wrap_int x = IT.wrapI_ (signed_int_ity, x) in + if String.equal s "ctz_proxy" then + rcval + (wrap_int (IT.arith_unop Terms.BW_CTZ_NoSMT (List.hd args_its) loc) loc) + state + else if List.exists (String.equal s) [ "ffs_proxy"; "ffsl_proxy"; "ffsll_proxy" ] + then + rcval + (wrap_int (IT.arith_unop Terms.BW_FFS_NoSMT (List.hd args_its) loc) loc) + state + else + bail) | CN_progs _ -> rcval (IT.unit_ loc) state | _ -> fail_n diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index a97bf0915..c9fde5226 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -1273,6 +1273,19 @@ let add_trace_information _labels annots = return () +let bytes_qpred sym size pointer init : RET.qpredicate_type = + let here = Locations.other __FUNCTION__ in + let bt' = WellTyped.quantifier_bt in + { q = (sym, bt'); + q_loc = here; + step = IT.num_lit_ Z.one bt' here; + permission = IT.(lt_ (sym_ (sym, bt', here), size) here); + name = Owned (Sctypes.uchar_ct, init); + pointer; + iargs = [] + } + + let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let (Expr (loc, annots, expect, e_)) = e in let@ () = add_trace_information labels annots in @@ -1289,6 +1302,10 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = debug 3 (lazy (item "expr" (group (Pp_mucore.pp_expr e)))); debug 3 (lazy (item "ctxt" (Context.pp ctxt)))) in + let bytes_qpred sym ct pointer init : RET.qpredicate_type = + let here = Locations.other __FUNCTION__ in + bytes_qpred sym (sizeOf_ ct here) pointer init + in (match e_ with | Epure pe -> let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe) in @@ -1561,8 +1578,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = and_ [ lower; upper ] here) in k result)) - | Memcpy _ (* (asym 'bty * asym 'bty * asym 'bty) *) -> - Cerb_debug.error "todo: Memcpy" + | Memcpy _ -> + (* should have been intercepted by memcpy_proxy *) + assert false | Memcmp _ (* (asym 'bty * asym 'bty * asym 'bty) *) -> Cerb_debug.error "todo: Memcmp" | Realloc _ (* (asym 'bty * asym 'bty * asym 'bty) *) -> @@ -1792,18 +1810,6 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let bytes_pred ct pointer init : RET.predicate_type = { name = Owned (ct, init); pointer; iargs = [] } in - let bytes_qpred sym ct pointer init : RET.qpredicate_type = - let here = Locations.other __FUNCTION__ in - let bt' = WellTyped.quantifier_bt in - { q = (sym, bt'); - q_loc = here; - step = IT.num_lit_ Z.one bt' here; - permission = IT.(lt_ (sym_ (sym, bt', here), sizeOf_ ct here) here); - name = Owned (Sctypes.uchar_ct, init); - pointer; - iargs = [] - } - in let bytes_constraints ~(value : IT.t) ~(byte_arr : IT.t) (ct : Sctypes.t) = (* FIXME this hard codes big endianness but this should be switchable *) let here = Locations.other __FUNCTION__ in @@ -2516,27 +2522,85 @@ let ffs_proxy_ft sz = ft -let add_stdlib_spec call_sigs fsym = - match Sym.has_id fsym with - (* FIXME: change the naming, we aren't unfolding these *) - | Some s when Setup.unfold_stdlib_name s -> - let add ft = - Pp.debug - 2 - (lazy (Pp.headline ("adding builtin spec for procedure " ^ Sym.pp_string fsym))); - add_fun_decl fsym (Locations.other __FUNCTION__, Some ft, Pmap.find fsym call_sigs) - in - if String.equal s "ctz_proxy" then - add ctz_proxy_ft - else if String.equal s "ffs_proxy" then - add (ffs_proxy_ft Sctypes.IntegerBaseTypes.Int_) - else if String.equal s "ffsl_proxy" then - add (ffs_proxy_ft Sctypes.IntegerBaseTypes.Long) - else if String.equal s "ffsll_proxy" then - add (ffs_proxy_ft Sctypes.IntegerBaseTypes.LongLong) - else - return () - | _ -> return () +let memcpy_proxy_ft = + let here = Locations.other __FUNCTION__ in + let info = (here, Some "memcpy_proxy") in + (* C arguments *) + let dest_sym, dest = IT.fresh_named (BT.Loc ()) "dest" here in + let src_sym, src = IT.fresh_named (BT.Loc ()) "src" here in + let n_sym, n = IT.fresh_named Memory.size_bt "n" here in + (* requires *) + let q_bt = WellTyped.quantifier_bt in + let uchar_bt = Memory.bt_of_sct Sctypes.uchar_ct in + let map_bt = BT.Map (q_bt, uchar_bt) in + let destIn_sym, _ = IT.fresh_named map_bt "destIn" here in + let srcIn_sym, srcIn = IT.fresh_named map_bt "srcIn" here in + let destRes str init = RET.Q (bytes_qpred (Sym.fresh_named str) n dest init) in + let srcRes str = RET.Q (bytes_qpred (Sym.fresh_named str) n src Init) in + (* ensures *) + let ret_sym, ret = IT.fresh_named (BT.Loc ()) "return" here in + let destOut_sym, destOut = IT.fresh_named map_bt "destOut" here in + let srcOut_sym, srcOut = IT.fresh_named map_bt "srcOut" here in + AT.mComputationals + [ (dest_sym, Loc (), info); (src_sym, Loc (), info); (n_sym, Memory.size_bt, info) ] + (AT.L + (LAT.mResources + [ ((destIn_sym, (destRes "i_d" Uninit, map_bt)), info); + ((srcIn_sym, (srcRes "i_s", map_bt)), info) + ] + (LAT.I + (RT.mComputational + ((ret_sym, BT.Loc ()), info) + (LRT.mResources + [ ((destOut_sym, (destRes "j_d" Init, map_bt)), info); + ((srcOut_sym, (srcRes "j_s", map_bt)), info) + ] + (LRT.Constraint + ( LC.T + (and_ + [ eq_ (ret, dest) here; + eq_ (srcIn, srcOut) here; + eq_ (srcIn, destOut) here + ] + here), + info, + I ))))))) + + +let add_stdlib_spec = + let module StrMap = Map.Make (String) in + let proxies = + List.fold_left + (fun map (name, ft) -> StrMap.add name ft map) + StrMap.empty + [ ("ctz_proxy", ctz_proxy_ft); + ("ffs_proxy", ffs_proxy_ft Sctypes.IntegerBaseTypes.Int_); + ("ffsl_proxy", ffs_proxy_ft Sctypes.IntegerBaseTypes.Long); + ("ffsll_proxy", ffs_proxy_ft Sctypes.IntegerBaseTypes.LongLong); + ("memcpy_proxy", memcpy_proxy_ft) + ] + in + let add ct fsym ft = + Pp.debug + 2 + (lazy (Pp.headline ("adding builtin spec for procedure " ^ Sym.pp_string fsym))); + add_fun_decl fsym (Locations.other __FUNCTION__, Some ft, ct) + in + fun call_sigs fsym -> + match + Option.( + let@ s = Sym.has_id fsym in + let@ ft = StrMap.find_opt s proxies in + (* The C signatures for most of the proxies are included in + ./runtime/libc/include/builtins.h, and so show up in every file, + regardless of whether or not they are used, but the same is not true + for memcpy (its C signature is only present when it is used) hence + (1) the extra lookup and (2) it being safe to skip if absent *) + let@ ct = Pmap.lookup fsym call_sigs in + return (ft, ct)) + with + | None -> return () + | Some (ft, ct) -> add ct fsym ft let record_and_check_datatypes datatypes = diff --git a/backend/cn/lib/setup.ml b/backend/cn/lib/setup.ml index ee55d19ab..90885b9a1 100644 --- a/backend/cn/lib/setup.ml +++ b/backend/cn/lib/setup.ml @@ -35,10 +35,3 @@ let conf macros incl_dirs incl_files astprints = cpp_cmd = cpp_str macros incl_dirs incl_files; cpp_stderr = true } - - -let unfold_proxies = - StringSet.of_list [ "ffs_proxy"; "ffsl_proxy"; "ffsll_proxy"; "ctz_proxy" ] - - -let unfold_stdlib_name s = StringSet.mem s unfold_proxies diff --git a/backend/cn/lib/setup.mli b/backend/cn/lib/setup.mli index 61ac95f10..1eed831cb 100644 --- a/backend/cn/lib/setup.mli +++ b/backend/cn/lib/setup.mli @@ -12,5 +12,3 @@ val conf string list -> Cerb_backend.Pipeline.language list -> Cerb_backend.Pipeline.configuration - -val unfold_stdlib_name : string -> bool diff --git a/tests/cn_vip_testsuite/cn_lemmas.h b/tests/cn_vip_testsuite/cn_lemmas.h index 290db965b..2042fec64 100644 --- a/tests/cn_vip_testsuite/cn_lemmas.h +++ b/tests/cn_vip_testsuite/cn_lemmas.h @@ -32,23 +32,6 @@ ensures (return != 0i32 || Src == Dest) && (return == 0i32 || Src != Dest); @*/ -void _memcpy(unsigned char *dest, unsigned char *src, size_t n); -/*@ spec _memcpy(pointer dest, pointer src, u64 n); - -requires - (u64) src + n <= (u64) dest || (u64) dest + n <= (u64) src; - (u64) src <= (u64) src + n; - (u64) dest <= (u64) dest + n; - take Src = each (u64 i; 0u64 <= i && i < n ) { Owned(array_shift(src, i)) }; - take Dest = each (u64 i; 0u64 <= i && i < n ) { Block(array_shift(dest, i)) }; - -ensures - take SrcR = each (u64 i; 0u64 <= i && i < n ) { Owned(array_shift(src, i)) }; - take DestR = each (u64 i; 0u64 <= i && i < n ) { Owned(array_shift(dest, i)) }; - Src == SrcR; - SrcR == DestR; -@*/ - /*@ lemma assert_equal(u64 x, u64 y) requires diff --git a/tests/cn_vip_testsuite/pointer_copy_memcpy.c b/tests/cn_vip_testsuite/pointer_copy_memcpy.c index 970ef81f7..813f148b2 100644 --- a/tests/cn_vip_testsuite/pointer_copy_memcpy.c +++ b/tests/cn_vip_testsuite/pointer_copy_memcpy.c @@ -10,7 +10,7 @@ int main() int *q; /*CN_VIP*//*@ to_bytes Owned(&p); @*/ /*CN_VIP*//*@ to_bytes Block(&q); @*/ - _memcpy ((unsigned char*)&q, (unsigned char*)&p, sizeof p); + memcpy((unsigned char*)&q, (unsigned char*)&p, sizeof p); /*CN_VIP*//*@ from_bytes Owned(&p); @*/ /*CN_VIP*//*@ from_bytes Owned(&q); @*/ #ifdef NO_ROUND_TRIP diff --git a/tests/run-cn-vip.sh b/tests/run-cn-vip.sh index b6640b154..9a2404c22 100755 --- a/tests/run-cn-vip.sh +++ b/tests/run-cn-vip.sh @@ -1,11 +1,6 @@ #!/usr/bin/env bash set -euo pipefail -o noclobber -# copying from run-ci.sh -# Z3=$(ocamlfind query z3) -# export DYLD_LIBRARY_PATH="${DYLD_LIBRARY_PATH:-}:${Z3}" -# export LD_LIBRARY_PATH="${LD_LIBRARY_PATH:-}:${Z3}" - USAGE="USAGE: $0 [-h]" function echo_and_err() { From e4de4e424cd8a3a62fef2636d446f853fee174c8 Mon Sep 17 00:00:00 2001 From: Michal Podhradsky Date: Thu, 7 Nov 2024 08:37:28 -0800 Subject: [PATCH 036/148] Build a truly multi platform docker image (#660) * Simplify the docker build, and properly build a multiplatform image with docker build actions * Temporarily disable scheduled docker build for faster testing * Clean up the release docker image * Add a separate job for RedHat docker image * Added RedHat dockerfile * Revert "Temporarily disable scheduled docker build for faster testing" This reverts commit 5afd2805a0367d50c4986943f2c505688d7c6de3. * Try to specify github tokens * Add CI badges: * Remove un-needed lines per @dc-mak 's suggestions --- .github/workflows/docker.yml | 60 ++++++++++++++++++++++------ Dockerfile.dev-env | 15 ------- Dockerfile.redhat | 38 ++++++++++++++++++ Dockerfile.release | 7 ---- Dockerfile.deps => Dockerfile.ubuntu | 11 +++-- Makefile_docker | 22 ---------- README.md | 2 +- 7 files changed, 94 insertions(+), 61 deletions(-) delete mode 100644 Dockerfile.dev-env create mode 100644 Dockerfile.redhat delete mode 100644 Dockerfile.release rename Dockerfile.deps => Dockerfile.ubuntu (62%) delete mode 100644 Makefile_docker diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index b8c8fd90e..f872e0a3c 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -5,7 +5,7 @@ on: - cron: '30 18 * * *' env: - CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn:release + CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn # Cancelling an in-progress job when a new push is performed causes the CI to # show up as failed: https://github.com/orgs/community/discussions/8336 @@ -15,12 +15,10 @@ concurrency: group: docker-${{ github.workflow }}-${{ github.ref }} cancel-in-progress: false +# Instructions from https://depot.dev/blog/multi-platform-docker-images-in-github-actions jobs: - deploy-docker: + docker-release-ubuntu: runs-on: ubuntu-latest - strategy: - matrix: - platform: [linux/amd64, linux/arm64] permissions: packages: write contents: read @@ -40,11 +38,47 @@ jobs: uses: docker/setup-qemu-action@v3 - name: Set up Docker Buildx uses: docker/setup-buildx-action@v3 - - name: Build the Docker image - run: | - echo "Building ${{env.CERBERUS_IMAGE_ID}}" - PLATFORM=${{ matrix.platform }} make -f Makefile_docker release_cn - docker tag cn:release ${{env.CERBERUS_IMAGE_ID}} - - - name: Push the Docker image - run: docker push ${{env.CERBERUS_IMAGE_ID}} + + - name: Build multi-platform image + uses: docker/build-push-action@v5 + with: + context: . + platforms: linux/amd64,linux/arm64 + push: true + tags: ${{env.CERBERUS_IMAGE_ID}}:release + file: Dockerfile.ubuntu + github-token: ${{ secrets.GITHUB_TOKEN }} + + docker-release-redhat: + runs-on: ubuntu-latest + permissions: + packages: write + contents: read + attestations: write + id-token: write + steps: + - uses: actions/checkout@v4 + + - name: Login to GitHub Container Registry + uses: docker/login-action@v3 + with: + registry: ghcr.io + username: ${{ github.actor }} + password: ${{ secrets.GITHUB_TOKEN }} + + - name: Set up QEMU + uses: docker/setup-qemu-action@v3 + - name: Set up Docker Buildx + uses: docker/setup-buildx-action@v3 + + - name: Build multi-platform image + uses: docker/build-push-action@v5 + with: + context: . + platforms: linux/amd64,linux/arm64 + push: true + tags: ${{env.CERBERUS_IMAGE_ID}}:release-redhat + file: Dockerfile.redhat + attests: type=sbom + provenance: mode=max + github-token: ${{ secrets.GITHUB_TOKEN }} diff --git a/Dockerfile.dev-env b/Dockerfile.dev-env deleted file mode 100644 index 3b240c135..000000000 --- a/Dockerfile.dev-env +++ /dev/null @@ -1,15 +0,0 @@ -FROM cerberus:deps - -#COPY --chown=user1 . /home/opam/cerberus/ -#RUN eval `opam env` && \ -# cd /home/opam/cerberus/ && \ -# make && \ -# make install -#COPY --chown=user1 docker_entry_point.sh /home/user1/ -#RUN chmod +x docker_entry_point.sh -#WORKDIR /data - -RUN echo 'export PS1="[\u@docker] \W # "' >> /home/user1/.bashrc -RUN echo 'eval $(opam env)' >> /home/user1/.bashrc - -ENTRYPOINT ["bash"] diff --git a/Dockerfile.redhat b/Dockerfile.redhat new file mode 100644 index 000000000..0c526a306 --- /dev/null +++ b/Dockerfile.redhat @@ -0,0 +1,38 @@ +FROM redhat/ubi9:latest + +# Install basic dependencies +RUN yum update -y && \ + yum install -y xz sudo gcc unzip \ + diffutils patch pkgconfig bzip2 \ + git perl wget ca-certificates \ + mpfr-devel gmp-devel m4 + +# Install additional FEDORA packages +# from https://www.cyberciti.biz/faq/install-epel-repo-on-an-rhel-8-x/ +# Currently the FEDORA packages are needed only for Z3 +# NOTE: we might have to eventually use *only* RedHat packages +# which would mean installing Z3 directly from the release page +RUN yum install -y https://dl.fedoraproject.org/pub/epel/epel-release-latest-9.noarch.rpm && \ + yum update -y && \ + yum install -y z3 + +# Install OPAM +# See https://opam.ocaml.org/doc/1.2/Install.html +RUN curl -fsSL https://opam.ocaml.org/install.sh | sh + +ENV OPAMCONFIRMLEVEL=unsafe-yes +RUN opam init --disable-sandboxing + +ADD . /opt/cerberus +WORKDIR /opt/cerberus +RUN opam install --deps-only ./cerberus-lib.opam ./cn.opam + +RUN eval `opam env` \ + && make install_cn + +WORKDIR /opt + +COPY docker_entry_point.sh /opt/docker_entry_point.sh +RUN chmod +x /opt/docker_entry_point.sh +WORKDIR /data +ENTRYPOINT ["/opt/docker_entry_point.sh"] diff --git a/Dockerfile.release b/Dockerfile.release deleted file mode 100644 index 9645a6309..000000000 --- a/Dockerfile.release +++ /dev/null @@ -1,7 +0,0 @@ -FROM cerberus:deps - -RUN rm -rf /opt/cerberus -COPY docker_entry_point.sh /opt/docker_entry_point.sh -RUN chmod +x /opt/docker_entry_point.sh -WORKDIR /data -ENTRYPOINT ["/opt/docker_entry_point.sh"] diff --git a/Dockerfile.deps b/Dockerfile.ubuntu similarity index 62% rename from Dockerfile.deps rename to Dockerfile.ubuntu index 3cf30851c..4fe361313 100644 --- a/Dockerfile.deps +++ b/Dockerfile.ubuntu @@ -1,3 +1,4 @@ +# Build a minimal release image FROM ubuntu:22.04 RUN apt-get update @@ -6,13 +7,17 @@ RUN apt-get install -y opam libgmp-dev libmpfr-dev ENV OPAMCONFIRMLEVEL=unsafe-yes RUN opam init --disable-sandboxing -RUN opam install dune lem ADD . /opt/cerberus WORKDIR /opt/cerberus RUN opam install --deps-only ./cerberus-lib.opam ./cn.opam + RUN eval `opam env` \ - && make install \ && make install_cn -WORKDIR /opt \ No newline at end of file +WORKDIR /opt + +COPY docker_entry_point.sh /opt/docker_entry_point.sh +RUN chmod +x /opt/docker_entry_point.sh +WORKDIR /data +ENTRYPOINT ["/opt/docker_entry_point.sh"] diff --git a/Makefile_docker b/Makefile_docker deleted file mode 100644 index f809b44a2..000000000 --- a/Makefile_docker +++ /dev/null @@ -1,22 +0,0 @@ -.PHONY: all release dev-env deps - -PLATFORM ?= linux/amd64 -$(info Building for platform $(PLATFORM)) - -all: - @echo 'targets: deps|release|dev-env' - -deps : - docker build --platform $(PLATFORM) --tag cerberus:deps -f Dockerfile.deps . - -release: deps - docker build --platform $(PLATFORM) --tag cerberus:release -f Dockerfile.release . - @echo 'for example: docker run --volume `PWD`:/data/ cerberus:release cerberus tests/tcc/00_assignment.c --pp=core' - -release_cn: deps - docker build --platform $(PLATFORM) --tag cn:release -f Dockerfile.release . - @echo 'for example: docker run --volume `PWD`:/data/ cn:release cerberus tests/tcc/00_assignment.c --pp=core' - -dev-env: deps - docker build --platform $(PLATFORM) --tag cerberus:dev-env -f Dockerfile.dev-env . - @echo 'for example: docker run -ti --volume `PWD`:/home/user1/cerberus/ cerberus:dev-env' diff --git a/README.md b/README.md index 2c3c1bb1e..ab6ccfde2 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Cerberus C semantics -[![CI](https://github.com/rems-project/cerberus/actions/workflows/ci.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci.yml) +[![CI](https://github.com/rems-project/cerberus/actions/workflows/ci.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci.yml) [![CI-CN](https://github.com/rems-project/cerberus/actions/workflows/ci-cn.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci-cn.yml) [![CI-CN-specs-testing](https://github.com/rems-project/cerberus/actions/workflows/ci-cn-spec-testing.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci-cn-spec-testing.yml) [![CI-CN-becnhmarks](https://github.com/rems-project/cerberus/actions/workflows/ci-cn-bench.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci-cn-bench.yml) [![CI-CHERI](https://github.com/rems-project/cerberus/actions/workflows/ci-cheri.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci-cheri.yml) [![Docker](https://github.com/rems-project/cerberus/actions/workflows/docker.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/docker.yml) Web interfaces, papers, and web page From ab58f67217a146425ac83cf8b93a3ef5c5334b53 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 7 Nov 2024 03:56:03 -0500 Subject: [PATCH 037/148] [CN-Test-Gen] Fix redundant backtracking for `map` --- runtime/libcn/include/cn-testing/dsl.h | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index 4ee05316f..5f649733d 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -125,8 +125,10 @@ if (0) { \ cn_label_##i##_backtrack: \ ; \ - char *toAdd[] = { __VA_ARGS__ }; \ - cn_gen_backtrack_relevant_add_many(toAdd); \ + if (cn_gen_backtrack_relevant_contains((char*)#i)) { \ + char *toAdd[] = { __VA_ARGS__ }; \ + cn_gen_backtrack_relevant_add_many(toAdd); \ + } \ goto cn_label_##last_var##_backtrack; \ } \ \ From f0e2d9a8e574030196d3bf0b9a75edf785e854a9 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 7 Nov 2024 14:41:48 -0500 Subject: [PATCH 038/148] [CN-Test-Gen] Add `--num-samples` arg --- backend/cn/bin/main.ml | 11 ++++++++++- backend/cn/lib/testGeneration/specTests.ml | 2 +- backend/cn/lib/testGeneration/testGenConfig.ml | 6 +++++- backend/cn/lib/testGeneration/testGenConfig.mli | 3 +++ 4 files changed, 19 insertions(+), 3 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 32e501c9b..cfcbe114a 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -434,6 +434,7 @@ let run_tests (* Test Generation *) output_dir dont_run + num_samples max_backtracks max_unfolds max_array_length @@ -486,7 +487,8 @@ let run_tests prog5 statement_locs; let config : TestGeneration.config = - { max_backtracks; + { num_samples; + max_backtracks; max_unfolds; max_array_length; null_in_every; @@ -865,6 +867,12 @@ module Testing_flags = struct Arg.(value & flag & info [ "no-run" ] ~doc) + let gen_num_samples = + let doc = "Set the number of samples to test" in + Arg.( + value & opt int TestGeneration.default_cfg.num_samples & info [ "num-samples" ] ~doc) + + let gen_backtrack_attempts = let doc = "Set the maximum attempts to satisfy a constraint before backtracking further, \ @@ -961,6 +969,7 @@ let testing_cmd = $ Executable_spec_flags.without_ownership_checking $ Testing_flags.output_test_dir $ Testing_flags.dont_run_tests + $ Testing_flags.gen_num_samples $ Testing_flags.gen_backtrack_attempts $ Testing_flags.gen_max_unfolds $ Testing_flags.test_max_array_length diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 5011b447e..7a6ab9dec 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -168,7 +168,7 @@ let compile_random_test_case |> List.hd |> string; Sym.pp inst.fn; - int 100; + int (Config.get_num_samples ()); separate_map (comma ^^ space) convert_from args ]) ^^ twice hardline diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index ed2383917..463fdd9b7 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -1,5 +1,6 @@ type t = { (* Compile time *) + num_samples : int; max_backtracks : int; max_unfolds : int option; max_array_length : int; @@ -14,7 +15,8 @@ type t = } let default = - { max_backtracks = 25; + { num_samples = 100; + max_backtracks = 25; max_unfolds = None; max_array_length = 50; null_in_every = None; @@ -50,3 +52,5 @@ let is_until_timeout () = !instance.until_timeout let is_exit_fast () = !instance.exit_fast let has_max_stack_depth () = !instance.max_stack_depth + +let get_num_samples () = !instance.num_samples diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 7a7a20aee..0ccc572be 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -1,5 +1,6 @@ type t = { (* Compile time *) + num_samples : int; max_backtracks : int; max_unfolds : int option; max_array_length : int; @@ -36,3 +37,5 @@ val is_until_timeout : unit -> int option val is_exit_fast : unit -> bool val has_max_stack_depth : unit -> int option + +val get_num_samples : unit -> int From ecad1122d829aed33e24b43cd6c87f0016f88c7f Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 7 Nov 2024 14:44:36 -0500 Subject: [PATCH 039/148] [CN-Test-Gen] Nicer abort on no testable functions --- backend/cn/bin/main.ml | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index cfcbe114a..591f7c5de 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -469,6 +469,16 @@ let run_tests ~f:(fun ~prog5 ~ail_prog ~statement_locs ~paused:_ -> Cerb_colour.without_colour (fun () -> + if + prog5 + |> Core_to_mucore.collect_instrumentation + |> fst + |> List.filter (fun (inst : Core_to_mucore.instrumentation) -> + Option.is_some inst.internal) + |> List.is_empty + then ( + print_endline "No testable functions, aborting"; + exit 1); if not (Sys.file_exists output_dir) then ( print_endline ("Directory \"" ^ output_dir ^ "\" does not exist."); Sys.mkdir output_dir 0o777; From 326dd9863c1265aa34ffa8aea3a9bdd74f3304b5 Mon Sep 17 00:00:00 2001 From: Rini Banerjee <26858592+rbanerjee20@users.noreply.github.com> Date: Fri, 8 Nov 2024 12:49:34 +0000 Subject: [PATCH 040/148] [CN-exec] Add a readme for Fulminate (#693) --- backend/cn/FULMINATE_README.md | 47 ++++++++++++++++++++++++++++++++++ backend/cn/README.md | 2 +- 2 files changed, 48 insertions(+), 1 deletion(-) create mode 100644 backend/cn/FULMINATE_README.md diff --git a/backend/cn/FULMINATE_README.md b/backend/cn/FULMINATE_README.md new file mode 100644 index 000000000..af98cd470 --- /dev/null +++ b/backend/cn/FULMINATE_README.md @@ -0,0 +1,47 @@ +# Fulminate + +Fulminate is a tool for translating CN specifications into C runtime assertions, which can then be checked using concrete test inputs. + +## Installation + +Fulminate is installed as part of the CN toolchain - see [README.md](README.md) for instructions. + +## Running Fulminate + +### Generating executable specifications + +To produce a file instrumented with CN runtime assertions, run: + +```bash +cn instrument .c +``` + +This will produce three files: + +* `-exec.c`, the instrumented source +* `cn.h`, a header file containing various definitions and prototypes, including C struct definitions representing CN datatypes, structs and records, as well as function prototypes for the various translated top-level CN functions and predicates. +* `cn.c`, a file that includes `cn.h` and provides definitions for the aforementioned prototypes + + +These are all produced in the directory the command was run from. Alternatively, one can provide an output directory for these three files (after creating the directory) using the `--output-dir` argument: + + +```bash +cn instrument .c --output-dir +``` + +The translation tool injects the executable precondition right before the source function body, at the start of the given function; the executable postcondition into a label called `cn_epilogue`, which gets jumped to via a `goto` wherever there is a return statement in the source; and the executable assertions inplace, wherever they were defined in the source. + +### Compiling, linking and running executable CN specifications + +To compile and link the output files described in the above section, and also to run these examples on some manually-produced concrete inputs (i.e. via a handwritten `main` function), one can run the following commands: + +```bash +export CHECK_SCRIPT="$OPAM_SWITCH_PREFIX/lib/cn/runtime/libexec/cn-runtime-single-file.sh" +$CHECK_SCRIPT .c +``` + +This runs the `cn-runtime-single-file.sh` script from the CN runtime library on `.c`, which generates the executable specification files, compiles and links these, and then runs the produced binary. This script is configurable with the `-n` option for disabling dynamic ownership checking and/or the `-q` option for running the script in quiet mode. This script can be found in `runtime/libcn/libexec` if you are interested in seeing the compile and link commands. + +The compile command includes the `-g` flag for collecting debug information, which means gdb or lldb can be run on the produced binary for setting breakpoints, stepping in and out of functions in a given run, printing concrete variable values at specific points in the program run, etc. gdb can cause problems on Mac due to some certification-related issues, so for Mac users we recommend you use lldb. + diff --git a/backend/cn/README.md b/backend/cn/README.md index 462558c92..d01710fa3 100644 --- a/backend/cn/README.md +++ b/backend/cn/README.md @@ -2,7 +2,7 @@ CN is tool for verifying C code is free of undefined behaviour and meets user-written specifications. It can also convert those specifications into -assertions to be checked at runtime during test cases. +C assertions to be checked at runtime on concrete test cases. ## Installation From af5dca5cee7b246604568b5090d6cb6f81a2b26d Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Fri, 8 Nov 2024 00:47:02 -0500 Subject: [PATCH 041/148] [CN-Test-Gen] Urn skips zero-weighted choices --- runtime/libcn/src/cn-testing/urn.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/runtime/libcn/src/cn-testing/urn.c b/runtime/libcn/src/cn-testing/urn.c index 182dd2e78..9109e71fa 100644 --- a/runtime/libcn/src/cn-testing/urn.c +++ b/runtime/libcn/src/cn-testing/urn.c @@ -75,7 +75,9 @@ struct int_urn* urn_from_array(uint64_t elems[], uint8_t len) { urn->size = 0; urn->tree = NULL; for (uint16_t i = 0; i < 2 * (uint16_t)len; i += 2) { - urn_insert(urn, elems[i], elems[i + 1]); + if (elems[i] != 0) { + urn_insert(urn, elems[i], elems[i + 1]); + } } return urn; } From 1135c43c3bc061fd9b67f309217fcf68419595ce Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Fri, 8 Nov 2024 16:21:56 -0500 Subject: [PATCH 042/148] [CN-Test-Gen] Make urn types more specific --- runtime/libcn/include/cn-testing/alloc.h | 2 +- runtime/libcn/include/cn-testing/dsl.h | 2 +- runtime/libcn/include/cn-testing/urn.h | 18 ++++++------ runtime/libcn/src/cn-testing/gen_alloc.c | 2 +- runtime/libcn/src/cn-testing/urn.c | 36 ++++++++++++------------ 5 files changed, 30 insertions(+), 30 deletions(-) diff --git a/runtime/libcn/include/cn-testing/alloc.h b/runtime/libcn/include/cn-testing/alloc.h index ec15f57b6..0b25fd38a 100644 --- a/runtime/libcn/include/cn-testing/alloc.h +++ b/runtime/libcn/include/cn-testing/alloc.h @@ -31,7 +31,7 @@ extern "C" { void cn_gen_ownership_update(void* p, size_t sz); - int cn_gen_ownership_check(cn_pointer* p, size_t sz); + int cn_gen_ownership_check(void* p, size_t sz); #ifdef __cplusplus } diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index 5f649733d..c260b98d8 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -156,7 +156,7 @@ tmp##_num_choices += 2; \ } \ tmp##_num_choices /= 2; \ - struct int_urn* tmp##_urn = urn_from_array(tmp##_choices, tmp##_num_choices); \ + struct cn_gen_int_urn* tmp##_urn = urn_from_array(tmp##_choices, tmp##_num_choices);\ cn_label_##tmp##_gen: \ ; \ alloc_checkpoint tmp##_checkpoint = alloc_save_checkpoint(); \ diff --git a/runtime/libcn/include/cn-testing/urn.h b/runtime/libcn/include/cn-testing/urn.h index f0159587a..64495f17e 100644 --- a/runtime/libcn/include/cn-testing/urn.h +++ b/runtime/libcn/include/cn-testing/urn.h @@ -7,26 +7,26 @@ extern "C" { #endif - struct int_tree { + struct cn_gen_int_tree { uint64_t weight; uint64_t value; - struct int_tree* left; - struct int_tree* right; + struct cn_gen_int_tree* left; + struct cn_gen_int_tree* right; }; - struct int_urn { + struct cn_gen_int_urn { uint8_t size; - struct int_tree* tree; + struct cn_gen_int_tree* tree; }; - struct int_urn* urn_from_array(uint64_t elems[], uint8_t len); + struct cn_gen_int_urn* urn_from_array(uint64_t elems[], uint8_t len); - void urn_insert(struct int_urn* urn, uint64_t weight, uint64_t value); + void urn_insert(struct cn_gen_int_urn* urn, uint64_t weight, uint64_t value); - uint64_t urn_remove(struct int_urn* urn); + uint64_t urn_remove(struct cn_gen_int_urn* urn); - void urn_free(struct int_urn* urn); + void urn_free(struct cn_gen_int_urn* urn); #ifdef __cplusplus } diff --git a/runtime/libcn/src/cn-testing/gen_alloc.c b/runtime/libcn/src/cn-testing/gen_alloc.c index e7577bc1b..a8b4add0b 100644 --- a/runtime/libcn/src/cn-testing/gen_alloc.c +++ b/runtime/libcn/src/cn-testing/gen_alloc.c @@ -154,7 +154,7 @@ void cn_gen_ownership_update(void* p, size_t sz) { update_ownership(p, sz); } -int cn_gen_ownership_check(cn_pointer* p, size_t sz) { +int cn_gen_ownership_check(void* p, size_t sz) { if (ownership_curr == ownership_buf) { return 1; } diff --git a/runtime/libcn/src/cn-testing/urn.c b/runtime/libcn/src/cn-testing/urn.c index 9109e71fa..539a46e6a 100644 --- a/runtime/libcn/src/cn-testing/urn.c +++ b/runtime/libcn/src/cn-testing/urn.c @@ -4,13 +4,13 @@ #include #include -int is_leaf(struct int_tree* tree) { +int is_leaf(struct cn_gen_int_tree* tree) { return tree->left == NULL && tree->right == NULL; } -uint64_t sample_tree_det(struct int_tree* tree, uint64_t index) { +uint64_t sample_tree_det(struct cn_gen_int_tree* tree, uint64_t index) { if (tree == NULL) { return -1; } @@ -26,20 +26,20 @@ uint64_t sample_tree_det(struct int_tree* tree, uint64_t index) { return sample_tree_det(tree->right, index - tree->left->weight); } -uint64_t sample_urn(struct int_urn* urn) { +uint64_t sample_urn(struct cn_gen_int_urn* urn) { uint64_t index = convert_from_cn_bits_u64(cn_gen_uniform_cn_bits_u64(urn->tree->weight)); return sample_tree_det(urn->tree, index); } -struct int_tree* insert_tree(uint8_t path, struct int_tree* tree, struct int_tree* leaf) { +struct cn_gen_int_tree* insert_tree(uint8_t path, struct cn_gen_int_tree* tree, struct cn_gen_int_tree* leaf) { if (tree == NULL) { return leaf; } if (is_leaf(tree)) { - struct int_tree* res = (struct int_tree*)malloc(sizeof(struct int_tree)); + struct cn_gen_int_tree* res = (struct cn_gen_int_tree*)malloc(sizeof(struct cn_gen_int_tree)); res->weight = tree->weight + leaf->weight; res->left = tree; res->right = leaf; @@ -57,8 +57,8 @@ struct int_tree* insert_tree(uint8_t path, struct int_tree* tree, struct int_tre return tree; } -void urn_insert(struct int_urn* urn, uint64_t weight, uint64_t value) { - struct int_tree* leaf = (struct int_tree*)malloc(sizeof(struct int_tree)); +void urn_insert(struct cn_gen_int_urn* urn, uint64_t weight, uint64_t value) { + struct cn_gen_int_tree* leaf = (struct cn_gen_int_tree*)malloc(sizeof(struct cn_gen_int_tree)); leaf->weight = weight; leaf->value = value; leaf->left = NULL; @@ -70,8 +70,8 @@ void urn_insert(struct int_urn* urn, uint64_t weight, uint64_t value) { -struct int_urn* urn_from_array(uint64_t elems[], uint8_t len) { - struct int_urn* urn = (struct int_urn*)malloc(sizeof(struct int_urn)); +struct cn_gen_int_urn* urn_from_array(uint64_t elems[], uint8_t len) { + struct cn_gen_int_urn* urn = (struct cn_gen_int_urn*)malloc(sizeof(struct cn_gen_int_urn)); urn->size = 0; urn->tree = NULL; for (uint16_t i = 0; i < 2 * (uint16_t)len; i += 2) { @@ -92,7 +92,7 @@ struct replace_res { uint64_t valueNew; }; -struct replace_res replace_tree(struct int_tree* tree, uint64_t weight, uint64_t value, uint64_t index) { +struct replace_res replace_tree(struct cn_gen_int_tree* tree, uint64_t weight, uint64_t value, uint64_t index) { if (tree == NULL) { assert(false); } @@ -128,7 +128,7 @@ struct replace_res replace_tree(struct int_tree* tree, uint64_t weight, uint64_t } } -uint64_t replace(struct int_urn* urn, uint64_t weight, uint64_t value, uint64_t index) { +uint64_t replace(struct cn_gen_int_urn* urn, uint64_t weight, uint64_t value, uint64_t index) { return replace_tree(urn->tree, weight, value, index).valueOld; } @@ -138,10 +138,10 @@ struct uninsert_res { uint64_t lowerBound; - struct int_tree* tree; + struct cn_gen_int_tree* tree; }; -struct uninsert_res uninsert_tree(uint8_t path, struct int_tree* tree) { +struct uninsert_res uninsert_tree(uint8_t path, struct cn_gen_int_tree* tree) { if (tree == NULL) { assert(false); } @@ -174,12 +174,12 @@ struct uninsert_res uninsert_tree(uint8_t path, struct int_tree* tree) { } } -struct uninsert_res uninsert_urn(struct int_urn* urn) { +struct uninsert_res uninsert_urn(struct cn_gen_int_urn* urn) { urn->size -= 1; return uninsert_tree(urn->size, urn->tree); } -uint64_t remove_urn_det(struct int_urn* urn, uint64_t index) { +uint64_t remove_urn_det(struct cn_gen_int_urn* urn, uint64_t index) { struct uninsert_res res = uninsert_urn(urn); if (res.tree == NULL) { @@ -197,12 +197,12 @@ uint64_t remove_urn_det(struct int_urn* urn, uint64_t index) { } } -uint64_t urn_remove(struct int_urn* urn) { +uint64_t urn_remove(struct cn_gen_int_urn* urn) { uint64_t index = convert_from_cn_bits_u64(cn_gen_uniform_cn_bits_u64(urn->tree->weight)); return remove_urn_det(urn, index); } -void tree_free(struct int_tree* tree) { +void tree_free(struct cn_gen_int_tree* tree) { if (tree == NULL) { return; } @@ -216,7 +216,7 @@ void tree_free(struct int_tree* tree) { return free(tree); } -void urn_free(struct int_urn* urn) { +void urn_free(struct cn_gen_int_urn* urn) { free(urn->tree); free(urn); } \ No newline at end of file From 36bb66267833b4561fb7001ffbf1ee28c001f0a9 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Fri, 8 Nov 2024 00:47:25 -0500 Subject: [PATCH 043/148] [CN-Test-Gen] Update BST example --- tests/cn-test-gen/src/bst.pass.c | 374 +++++++++++++++++-------------- 1 file changed, 206 insertions(+), 168 deletions(-) diff --git a/tests/cn-test-gen/src/bst.pass.c b/tests/cn-test-gen/src/bst.pass.c index 0881e3542..1354ab10a 100644 --- a/tests/cn-test-gen/src/bst.pass.c +++ b/tests/cn-test-gen/src/bst.pass.c @@ -1,67 +1,127 @@ -/* A set defined as binary search tree */ +#include + +#define KEY int +#define VALUE long struct MapNode { - int key; - int ignore; - long value; - struct MapNode* smaller; - struct MapNode* larger; -}; -struct MapNode* malloc_MapNode(); -struct Map { - struct MapNode* root; + KEY key; + VALUE value; + struct MapNode *smaller; + struct MapNode *larger; }; -struct Map map_empty(); -_Bool map_lookup(struct Map map, int key, long* value); -// Functional Sepcification of Binary Search Tree +extern void* cn_malloc(size_t size); +extern void cn_free_sized(void *ptr, size_t size); + + /*@ + type_synonym KEY = i32 type_synonym VALUE = i64 type_synonym NodeData = { KEY key, VALUE value } -type_synonym Interval = { KEY lower, KEY upper, boolean empty } +function (KEY) defaultKey() { 0i32 } -function (Interval) emptyInterval() { - { lower: 0i32, upper: 0i32, empty: true } +datatype ValueOption { + ValueNone {}, + ValueSome { VALUE value } } +// ----------------------------------------------------------------------------- +// Intervals -function (Interval) joinInterval(Interval smaller, Interval larger) { - if (smaller.empty) { - larger - } else { - if (larger.empty) { - smaller - } else { - { lower: smaller.lower, upper: larger.upper, empty: false } - }} +// Non-empty, closed intervals +type_synonym Interval = { KEY lower, KEY upper } + +function (Interval) defaultInterval() { + { lower: defaultKey(), upper: defaultKey() } } +datatype IntervalOption { + IntervalNone {}, + IntervalSome { Interval i } +} + +function (boolean) isIntervalSome(IntervalOption i) { + match i { + IntervalNone {} => { false } + IntervalSome { i:_ } => { true } + } +} + +function (Interval) fromIntervalOption(IntervalOption i) { + match i { + IntervalNone {} => { defaultInterval() } + IntervalSome { i:j } => { j } + } +} + + +function (IntervalOption) + joinInterval(IntervalOption optSmaller, KEY val, IntervalOption optLarger) { + match optSmaller { + IntervalNone {} => { + match optLarger { + IntervalNone {} => { + IntervalSome { i: { lower: val, upper: val } } + } + IntervalSome { i: larger } => { + if (val < larger.lower) { + IntervalSome { i: { lower: val, upper: larger.upper } } + } else { + IntervalNone {} + } + } + } + } + IntervalSome { i: smaller } => { + if (val > smaller.upper) { + match optLarger { + IntervalNone {} => { + IntervalSome { i: { lower: smaller.lower, upper: val } } + } + IntervalSome { i: larger } => { + if (val < larger.lower) { + IntervalSome { i: { lower: smaller.lower, upper: larger.upper } } + } else { + IntervalNone {} + } + } + } + } else { + IntervalNone {} + } + } + } +} + + + +// ----------------------------------------------------------------------------- + + + + // A binary dearch tree datatype BST { Leaf {}, Node { NodeData data, BST smaller, BST larger } } -// A selector for the case when we know that the tree is a `Node`. -function ({ NodeData data, BST smaller, BST larger }) fromBSTNode(BST node) { - match node { - Leaf {} => { { data: { key: 0i32, value: 0i64 }, smaller: Leaf {}, larger: Leaf {} } } - Node { data: data, smaller: smaller, larger: larger } => { - { data: data, smaller: smaller, larger: larger } - } +function (boolean) hasRoot(KEY key, BST tree) { + match tree { + Leaf {} => { false } + Node { data: data, smaller: _, larger: _ } => { data.key == key } } } - -function [rec] (VALUE) lookup(KEY key, BST tree) { +function [rec] (ValueOption) lookup(KEY key, BST tree) { match tree { - Leaf {} => { 0i64 } + Leaf {} => { ValueNone {} } Node { data: data, smaller: smaller, larger: larger } => { if (data.key == key) { - data.value + ValueSome { value: data.value } } else { if (data.key < key) { lookup(key,larger) @@ -86,23 +146,25 @@ function [rec] (boolean) member(KEY k, BST tree) { function [rec] (BST) insert(KEY key, VALUE value, BST tree) { match tree { - Leaf {} => { Node { data: { key: key, value: value }, smaller: Leaf {}, larger: Leaf {} } } + Leaf {} => { Node { data: { key: key, value: value }, + smaller: Leaf {}, larger: Leaf {} } } Node { data: data, smaller: smaller, larger: larger } => { if (data.key == key) { - Node { data: { key: key, value: value }, smaller: smaller, larger: larger } + Node { data: { key: key, value: value }, + smaller: smaller, larger: larger } } else { if (data.key < key) { - Node { data: data, smaller: smaller, larger: insert(key,value,larger) } + Node { data: data, + smaller: smaller, larger: insert(key,value,larger) } } else { - Node { data: data, smaller: insert(key,value,smaller), larger: larger } + Node { data: data, + smaller: insert(key,value,smaller), larger: larger } } } } } } - - function [rec] (BST) setKey(KEY k, BST root, BST value) { match root { Leaf {} => { value } @@ -117,18 +179,7 @@ function [rec] (BST) setKey(KEY k, BST root, BST value) { } -@*/ -// Specialized `malloc` -extern struct MapNode* malloc_MapNode(); -/*@ -spec malloc_MapNode(); -requires - true; -ensures - take v = Block(return); -@*/ -/*@ // ***************************************************************************** // Consuming an entire tree @@ -140,7 +191,7 @@ function (NodeData) getNodeData(struct MapNode node) { { key: node.key, value: node.value } } -type_synonym RangedBST = { BST tree, Interval range } +type_synonym RangedBST = { BST tree, IntervalOption range } type_synonym RangedNode = { struct MapNode node, BST smaller, @@ -148,30 +199,25 @@ type_synonym RangedNode = { Interval range } -function (boolean) validBST(struct MapNode node, Interval smaller, Interval larger) { - (smaller.empty || smaller.upper < node.key) && - (larger.empty || node.key < larger.lower) -} - - predicate RangedNode RangedNode(pointer root) { take node = Owned(root); take smaller = RangedBST(node.smaller); take larger = RangedBST(node.larger); - assert (validBST(node, smaller.range, larger.range)); + let rangeOpt = joinInterval(smaller.range, node.key, larger.range); + assert (isIntervalSome(rangeOpt)); return { node: node, smaller: smaller.tree, larger: larger.tree, - range: joinInterval(smaller.range, larger.range) }; + range: fromIntervalOption(rangeOpt) }; } // A binary search tree, and the interval for all its keys. predicate RangedBST RangedBST(pointer root) { if (is_null(root)) { - return { tree: Leaf {}, range: emptyInterval() }; + return { tree: Leaf {}, range: IntervalNone{} }; } else { take node = RangedNode(root); let data = getNodeData(node.node); return { tree: Node { data: data, smaller: node.smaller, larger: node.larger }, - range: node.range }; + range: IntervalSome { i: node.range } }; } } @@ -196,30 +242,6 @@ datatype BSTFocus { AtNode { BST done, struct MapNode node, BST smaller, BST larger } } -function (struct MapNode) default_map_node() { - struct MapNode { - key: 0i32, - ignore: 0i32, - value: 0i64, - smaller: NULL, - larger: NULL - } -} - -function (BSTNodeFocus) default_node_focus() { - { done: Leaf {}, node: default_map_node(), smaller: Leaf {}, larger: Leaf {} } -} - -// Access focus data, when we already know that we are at a node. -function (BSTNodeFocus) fromBSTFocusNode(BSTFocus focus) { - match focus { - AtLeaf { tree: _ } => { default_node_focus() } - AtNode { done: done, node: node, smaller: smaller, larger: larger } => { - { done: done, node: node, smaller: smaller, larger: larger } - } - } -} - predicate BSTFocus BSTFocus(pointer root, pointer child) { if (is_null(child)) { take tree = BST(root); @@ -237,7 +259,7 @@ predicate BSTFocus BSTFocus(pointer root, pointer child) { // `child` is the node stored at `c`. predicate RangedBST BSTNodeUpTo(pointer p, pointer c, struct MapNode child, Interval range) { if (ptr_eq(p,c)) { - return { tree: Leaf {}, range: range }; + return { tree: Leaf {}, range: IntervalSome { i: range } }; } else { take parent = Owned(p); take result = BSTNodeChildUpTo(c, child, range, parent); @@ -252,19 +274,23 @@ predicate RangedBST if (parent.key < target.key) { take small = RangedBST(parent.smaller); take large = BSTNodeUpTo(parent.larger, c, target, range); - assert(validBST(parent, small.range, large.range)); - return { tree: Node { data: getNodeData(parent), smaller: small.tree, larger: large.tree }, - range: joinInterval(small.range,large.range) }; + let node = getNodeData(parent); + let optRange = joinInterval(small.range, node.key, large.range); + assert(isIntervalSome(optRange)); + return { tree: Node { data: node, smaller: small.tree, larger: large.tree }, + range: optRange }; } else { if (parent.key > target.key) { take small = BSTNodeUpTo(parent.smaller, c, target, range); take large = RangedBST(parent.larger); - assert(validBST(parent, small.range, large.range)); - return { tree: Node { data: getNodeData(parent), smaller: small.tree, larger: large.tree }, - range: joinInterval(small.range,large.range) }; + let node = getNodeData(parent); + let optRange = joinInterval(small.range, node.key, large.range); + assert(isIntervalSome(optRange)); + return { tree: Node { data: node, smaller: small.tree, larger: large.tree }, + range: optRange }; } else { // We should never get here, but asserting `false` is not allowed - return { tree: Leaf {}, range: emptyInterval() }; + return { tree: Leaf {}, range: IntervalNone {} }; }} } @@ -273,7 +299,7 @@ function (BST) unfocus(BSTFocus focus) { AtLeaf { tree: tree } => { tree } AtNode { done: tree, node: node, smaller: smaller, larger: larger } => { let bst = Node { data: getNodeData(node), smaller: smaller, larger: larger }; - setKey(node.key, tree, bst) + setKey(node.key, tree, bst) } } } @@ -287,85 +313,97 @@ function (BST) focusDone(BSTFocus focus) { -lemma FocusedGo(pointer root, pointer cur, boolean smaller) - requires - !is_null(cur); - take focus = BSTFocus(root,cur); - ensures - let node = fromBSTFocusNode(focus).node; - take new_focus = BSTFocus(root, if (smaller) { node.smaller } else { node.larger }); - unfocus(focus) == unfocus(new_focus); - - -// It's quite unfortunate that we have to copy the lemma here. -lemma FocusedGoKey(pointer root, pointer cur, boolean smaller, KEY key) - requires - !is_null(cur); - take focus = BSTFocus(root,cur); - ensures - let node = fromBSTFocusNode(focus).node; - take new_focus = BSTFocus(root, if (smaller) { node.smaller } else { node.larger }); - unfocus(focus) == unfocus(new_focus); +@*/ - if (!member(key, focusDone(focus)) && node.key != key) { - !member(key, focusDone(new_focus)) - } else { - true - }; +/* Allocate a new singleton node */ +struct MapNode *newNode(KEY key, VALUE value) +/*@ +requires + true; +ensures + take node = Owned(return); + node.key == key; + node.value == value; + is_null(node.smaller); + is_null(node.larger); +@*/ +{ + struct MapNode *node = (struct MapNode*)cn_malloc(sizeof(struct MapNode)); + node->key = key; + node->value = value; + node->smaller = 0; + node->larger = 0; + return node; +} +struct MapNode *findParent(struct MapNode **node, KEY key) +/*@ +requires + take tree_ptr = Owned(node); + take tree = BST(tree_ptr); +ensures + take cur_ptr = Owned(node); + let not_found = is_null(cur_ptr); + not_found == !member(key, tree); + take focus = BSTFocus(tree_ptr, return); + unfocus(focus) == tree; + match focus { + AtLeaf { tree: _ } => { + not_found || ptr_eq(cur_ptr,tree_ptr) && hasRoot(key, tree) + } + AtNode { done: _, node: parent, smaller: _, larger: _ } => { + let tgt = if (key < parent.key) { parent.smaller } else { parent.larger }; + ptr_eq(cur_ptr,tgt) + } + }; @*/ -/* Look for a node and its parent */ -struct MapNode* findNode(struct MapNode* root, int key) - /*@ - requires - take tree = BST(root); - ensures - take focus = BSTFocus(root, return); - unfocus(focus) == tree; - match focus { - AtLeaf { tree: _ } => { !member(key,tree) } - AtNode { done: _, node: node, smaller: _, larger: _ } => { - node.key == key - } - }; - @*/ { - struct MapNode* cur = root; - /*@ split_case is_null(cur); @*/ - /*@ unfold setKey(fromBSTNode(tree).data.key, Leaf {}, tree); @*/ - /*@ unfold member(key, Leaf {}); @*/ - while (cur) - /*@ inv - {root} unchanged; - {key} unchanged; - take focus = BSTFocus(root,cur); - unfocus(focus) == tree; - !member(key, focusDone(focus)); - let cur_prev = cur; - @*/ - { - int k = cur->key; - if (k == key) return cur; - cur = k < key ? cur->larger : cur->smaller; - /*@ apply FocusedGoKey(root, cur_prev, k > key, key); @*/ + struct MapNode *parent = 0; + struct MapNode *cur = *node; + while (cur) + { + KEY k = cur->key; + if (k == key) { + *node = cur; + return parent; } - return 0; + parent = cur; + cur = k < key? cur->larger : cur->smaller; + } + *node = cur; + return parent; } + +/* Insert an element into a map. Overwrites previous if already present. */ +void map_insert(struct MapNode **root, KEY key, VALUE value) /*@ -predicate BSTFocus FindParentFocus(pointer tree_ptr, pointer cur_ptr, pointer parent_ptr, KEY key) { - if (is_null(cur_ptr)) { - take focus = BSTFocus(tree_ptr, parent_ptr); - let tree_after = unfocus(focus); - assert(!member(key,tree_after)); // More? - return focus; +requires + take root_ptr = Owned(root); + take tree = BST(root_ptr); +ensures + take new_root = Owned(root); + take new_tree = BST(new_root); + new_tree == insert(key, value, tree); +@*/ +{ + struct MapNode *search = *root; + struct MapNode *parent = findParent(&search, key); + if (search) { + search->value = value; + return; + } + + if (!parent) { + *root = newNode(key,value); + return; + } + + struct MapNode *new_node = newNode(key,value); + if (parent->key < key) { + parent->larger = new_node; } else { - // Found in tree - take focus = BSTFocus(tree_ptr, cur_ptr); - let at_node = fromBSTFocusNode(focus); - assert(at_node.node.key == key); - return focus; + parent->smaller = new_node; } -} -@*/ \ No newline at end of file +} \ No newline at end of file From c8e4c1207c73de9975b9f0ec3b8b1108b9862d22 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Sat, 9 Nov 2024 00:20:59 -0500 Subject: [PATCH 044/148] [CN-Test-Gen] Fix backtracking for stack depth --- backend/cn/lib/testGeneration/genCodeGen.ml | 20 ++++++++-- backend/cn/lib/testGeneration/genRuntime.ml | 40 +++++++++++++------- backend/cn/lib/testGeneration/genRuntime.mli | 3 +- runtime/libcn/include/cn-testing/dsl.h | 11 ++++-- runtime/libcn/src/cn-testing/backtrack.c | 7 +++- 5 files changed, 58 insertions(+), 23 deletions(-) diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index bc0df5b62..c4b2faa09 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -135,7 +135,7 @@ let rec compile_term let alloc_sym = Sym.fresh_named "cn_gen_alloc" in let b, s, e = compile_it sigma name it in (b, s, mk_expr (AilEcall (mk_expr (AilEident alloc_sym), [ e ]))) - | Call { fsym; iargs; oarg_bt } -> + | Call { fsym; iargs; oarg_bt; path_vars } -> let sym = GenUtils.get_mangled_name (fsym :: List.map fst iargs) in let es = iargs |> List.map snd |> List.map (fun x -> A.(mk_expr (AilEident x))) in let x = Sym.fresh () in @@ -163,8 +163,20 @@ let rec compile_term if GenBuiltins.is_builtin sym then [] else - [ macro_call "CN_GEN_CALL_FROM" from_vars; macro_call "CN_GEN_CALL_TO" to_vars ] - ), + (if List.is_empty from_vars then + [] + else + [ macro_call "CN_GEN_CALL_FROM" from_vars; + macro_call "CN_GEN_CALL_TO" to_vars + ]) + @ + if GR.SymSet.is_empty path_vars then + [] + else + [ macro_call + "CN_GEN_CALL_PATH_VARS" + (path_vars |> GR.SymSet.to_seq |> List.of_seq |> List.map wrap_to_string) + ]), mk_expr (AilEident x) ) | Asgn { pointer; offset; sct; value; last_var; rest } -> let tmp_sym = Sym.fresh () in @@ -253,7 +265,7 @@ let rec compile_term (Option.value ~default:name (match value with - | Call { fsym; iargs; oarg_bt = _ } -> + | Call { fsym; iargs; oarg_bt = _; path_vars = _ } -> Some (GenUtils.get_mangled_name (fsym :: List.map fst iargs)) diff --git a/backend/cn/lib/testGeneration/genRuntime.ml b/backend/cn/lib/testGeneration/genRuntime.ml index 84b07226c..60da94dcb 100644 --- a/backend/cn/lib/testGeneration/genRuntime.ml +++ b/backend/cn/lib/testGeneration/genRuntime.ml @@ -27,7 +27,8 @@ type term = | Call of { fsym : Sym.t; iargs : (Sym.t * Sym.t) list; - oarg_bt : BT.t + oarg_bt : BT.t; + path_vars : SymSet.t } | Asgn of { pointer : Sym.t; @@ -76,7 +77,8 @@ let rec free_vars_term (tm : term) : SymSet.t = | Pick { bt = _; choice_var = _; choices; last_var = _ } -> free_vars_term_list (List.map snd choices) | Alloc { bytes } -> IT.free_vars bytes - | Call { fsym = _; iargs; oarg_bt = _ } -> SymSet.of_list (List.map snd iargs) + | Call { fsym = _; iargs; oarg_bt = _; path_vars = _ } -> + SymSet.of_list (List.map snd iargs) | Asgn { pointer; offset; sct = _; value; last_var = _; rest } -> List.fold_left SymSet.union @@ -132,7 +134,7 @@ let rec pp_term (tm : term) : Pp.document = (int w ^^ comma ^^ braces (nest 2 (break 1 ^^ pp_term gt)))) choices))) | Alloc { bytes } -> string "alloc" ^^ parens (IT.pp bytes) - | Call { fsym; iargs; oarg_bt } -> + | Call { fsym; iargs; oarg_bt; path_vars } -> parens (Sym.pp fsym ^^ parens @@ -143,7 +145,16 @@ let rec pp_term (tm : term) : Pp.document = (fun (x, y) -> Sym.pp x ^^ colon ^^ space ^^ Sym.pp y) iargs)) ^^ space - ^^ BT.pp oarg_bt) + ^^ colon + ^^ space + ^^ BT.pp oarg_bt + ^^ c_comment + (string "path affected by" + ^^ space + ^^ separate_map + (comma ^^ space) + Sym.pp + (path_vars |> SymSet.to_seq |> List.of_seq))) | Asgn { pointer : Sym.t; offset : IT.t; @@ -312,7 +323,7 @@ let nice_names (inputs : SymSet.t) (gt : GT.t) : GT.t = let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = - let rec aux (vars : Sym.t list) (gt : GT.t) : term = + let rec aux (vars : Sym.t list) (path_vars : SymSet.t) (gt : GT.t) : term = let last_var = match vars with v :: _ -> v | [] -> bennet in let (GT (gt_, bt, loc)) = gt in match gt_ with @@ -347,7 +358,7 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = Z.to_int (Z.max Z.one (Z.div w (Z.div (Z.add w_sum (Z.pred max_int)) max_int))) in - List.map (fun (w, gt) -> (f w, aux (choice_var :: vars) gt)) wgts); + List.map (fun (w, gt) -> (f w, aux (choice_var :: vars) path_vars gt)) wgts); last_var } | Alloc bytes -> Alloc { bytes } @@ -373,7 +384,7 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = xits ([], fun _ gr -> gr) in - gt_lets last_var (Call { fsym; iargs; oarg_bt = bt }) + gt_lets last_var (Call { fsym; iargs; oarg_bt = bt; path_vars }) | Asgn ((it_addr, sct), value, rest) -> let pointer, offset = GA.get_addr_offset it_addr in if not (SymSet.mem pointer inputs || List.exists (Sym.equal pointer) vars) then @@ -383,20 +394,21 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = ^ String.concat "; " (List.map Sym.pp_string vars) ^ "] from " ^ Pp.plain (Locations.pp (IT.loc it_addr))); - Asgn { pointer; offset; sct; value; last_var; rest = aux vars rest } + Asgn { pointer; offset; sct; value; last_var; rest = aux vars path_vars rest } | Let (backtracks, (x, gt1), gt2) -> Let { backtracks; x; x_bt = GT.bt gt1; - value = aux vars gt1; + value = aux vars path_vars gt1; last_var; - rest = aux (x :: vars) gt2 + rest = aux (x :: vars) path_vars gt2 } | Return value -> Return { value } - | Assert (prop, rest) -> Assert { prop; last_var; rest = aux vars rest } + | Assert (prop, rest) -> Assert { prop; last_var; rest = aux vars path_vars rest } | ITE (cond, gt_then, gt_else) -> - ITE { bt; cond; t = aux vars gt_then; f = aux vars gt_else } + let path_vars = SymSet.union path_vars (IT.free_vars cond) in + ITE { bt; cond; t = aux vars path_vars gt_then; f = aux vars path_vars gt_else } | Map ((i, i_bt, perm), inner) -> let min, max = GenAnalysis.get_bounds (i, i_bt) perm in Map @@ -405,11 +417,11 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = min; max; perm; - inner = aux (i :: vars) inner; + inner = aux (i :: vars) path_vars inner; last_var } in - aux [] (nice_names inputs gt) + aux [] SymSet.empty (nice_names inputs gt) type definition = diff --git a/backend/cn/lib/testGeneration/genRuntime.mli b/backend/cn/lib/testGeneration/genRuntime.mli index 5276abd22..7147ef4b8 100644 --- a/backend/cn/lib/testGeneration/genRuntime.mli +++ b/backend/cn/lib/testGeneration/genRuntime.mli @@ -22,7 +22,8 @@ type term = | Call of { fsym : Sym.t; iargs : (Sym.t * Sym.t) list; - oarg_bt : BT.t + oarg_bt : BT.t; + path_vars : SymSet.t } | Asgn of { pointer : Sym.t; diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index c260b98d8..a93c181de 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -13,12 +13,11 @@ cn_gen_backtrack_decrement_depth(); \ return NULL; \ } \ + cn_gen_backtrack_increment_depth(); \ if (cn_gen_backtrack_depth() == cn_gen_backtrack_max_depth()) { \ cn_gen_backtrack_depth_exceeded(); \ goto cn_label_bennet_backtrack; \ - } else { \ - cn_gen_backtrack_increment_depth(); \ - } \ + } #define CN_GEN_UNIFORM(ty, sz) cn_gen_uniform_##ty(sz) @@ -45,6 +44,12 @@ cn_gen_backtrack_relevant_remap_many(from, to); \ } +#define CN_GEN_CALL_PATH_VARS(...) \ + if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_DEPTH) { \ + char* toAdd[] = { __VA_ARGS__, NULL }; \ + cn_gen_backtrack_relevant_add_many(toAdd); \ + } + #define CN_GEN_ASSIGN(p, offset, addr_ty, value, tmp, gen_name, last_var, ...) \ if (convert_from_cn_pointer(p) == 0) { \ cn_gen_backtrack_assert_failure(); \ diff --git a/runtime/libcn/src/cn-testing/backtrack.c b/runtime/libcn/src/cn-testing/backtrack.c index a7db8aac2..2cd109e9d 100644 --- a/runtime/libcn/src/cn-testing/backtrack.c +++ b/runtime/libcn/src/cn-testing/backtrack.c @@ -42,8 +42,13 @@ static size_t more_alloc_needed = 0; void cn_gen_backtrack_reset(void) { type = CN_GEN_BACKTRACK_NONE; - to_retry = NULL; more_alloc_needed = 0; + + while (to_retry != NULL) { + void* tmp = to_retry->next; + free(to_retry); + to_retry = tmp; + } } void cn_gen_backtrack_assert_failure(void) { From 3f5bef0d93bd58e746bfaa4aaca34fa399c09312 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Sat, 9 Nov 2024 23:26:01 -0500 Subject: [PATCH 045/148] [CN-Test-Gen] Reorder local variables after calls --- backend/cn/lib/testGeneration/genOptimize.ml | 115 +++++++++++++------ backend/cn/lib/testGeneration/genTerms.ml | 18 +-- 2 files changed, 88 insertions(+), 45 deletions(-) diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 859d84e94..40e252b0d 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -2165,43 +2165,71 @@ module Reordering = struct module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) - let get_variable_ordering (iargs : SymSet.t) (stmts : GS.t list) : Sym.t list = + let get_variable_ordering (_rec_fsyms : SymSet.t) (iargs : SymSet.t) (stmts : GS.t list) + : Sym.t list + = let module Oper = Graph.Oper.P (SymGraph) in - (* Describes logical dependencies where [x <- y] means that [x] depends on [y] *) - let collect_constraints (stmts : GS.t list) : SymGraph.t = - let rec aux (stmts : GS.t list) : SymGraph.t = - match stmts with - | Let (_, (x, _)) :: stmts' -> SymGraph.add_vertex (aux stmts') x - | Assert (T (IT (Binop (EQ, IT (Sym x, _, _), it), _, _))) :: stmts' -> - let g = aux stmts' in - let g' = - List.fold_left - (fun g' y -> - if SymSet.mem y iargs || Sym.equal x y then - g' - else - SymGraph.add_edge_e g' (y, x)) - g - (it |> IT.free_vars |> SymSet.to_seq |> List.of_seq) - in - g' - | Assert (T (IT (Binop (EQ, it, IT (Sym x, _, _)), _, _))) :: stmts' -> - let g = aux stmts' in - Seq.fold_left + (* Insert edges x <- y_1, ..., y_n when x = f(y_1, ..., y_n) *) + let rec consider_equalities (stmts : GS.t list) : SymGraph.t = + match stmts with + | Let (_, (x, _)) :: stmts' -> SymGraph.add_vertex (consider_equalities stmts') x + | Assert (T (IT (Binop (EQ, IT (Sym x, _, _), it), _, _))) :: stmts' -> + let g = consider_equalities stmts' in + let g' = + List.fold_left (fun g' y -> if SymSet.mem y iargs || Sym.equal x y then g' else SymGraph.add_edge_e g' (y, x)) g - (it |> IT.free_vars |> SymSet.to_seq) - | _ :: stmts' -> aux stmts' - | [] -> SymGraph.empty - in - let g = aux stmts in + (it |> IT.free_vars |> SymSet.to_seq |> List.of_seq) + in + g' + | Assert (T (IT (Binop (EQ, it, IT (Sym x, _, _)), _, _))) :: stmts' -> + let g = consider_equalities stmts' in + Seq.fold_left + (fun g' y -> + if SymSet.mem y iargs || Sym.equal x y then + g' + else + SymGraph.add_edge_e g' (y, x)) + g + (it |> IT.free_vars |> SymSet.to_seq) + | _ :: stmts' -> consider_equalities stmts' + | [] -> SymGraph.empty + in + (* Put calls before local variables they constrain *) + let rec consider_constrained_calls + (from_calls : SymSet.t) + (g : SymGraph.t) + (stmts : GS.t list) + : SymGraph.t + = + match stmts with + | Let (_, (x, gt)) :: stmts' when GT.contains_call gt -> + consider_constrained_calls (SymSet.add x from_calls) g stmts' + | Asgn _ :: stmts' | Let _ :: stmts' -> + consider_constrained_calls from_calls g stmts' + | Assert lc :: stmts' -> + let g = consider_constrained_calls from_calls g stmts' in + let free_vars = LC.free_vars lc in + let call_vars = SymSet.inter free_vars from_calls in + let non_call_vars = SymSet.diff free_vars from_calls in + let add_from_call (x : Sym.t) (g : SymGraph.t) : SymGraph.t = + SymSet.fold (fun y g' -> SymGraph.add_edge g' y x) call_vars g + in + SymSet.fold add_from_call non_call_vars g + | [] -> g + in + (* Describes logical dependencies where [x <- y] means that [x] depends on [y] *) + let collect_constraints (stmts : GS.t list) : SymGraph.t = + let g = consider_equalities stmts in let g' = Oper.transitive_closure g in - assert (not (SymGraph.fold_edges (fun x y acc -> Sym.equal x y || acc) g' false)); - g + let g'' = consider_constrained_calls SymSet.empty g' stmts in + let g''' = Oper.transitive_closure g'' in + assert (not (SymGraph.fold_edges (fun x y acc -> Sym.equal x y || acc) g''' false)); + g''' in (* Describes data dependencies where [x <- y] means that [x] depends on [y] *) let collect_dependencies (stmts : GS.t list) : SymGraph.t = @@ -2273,7 +2301,9 @@ module Reordering = struct loop orig_order - let get_statement_ordering (iargs : SymSet.t) (stmts : GS.t list) : GS.t list = + let get_statement_ordering (rec_fsyms : SymSet.t) (iargs : SymSet.t) (stmts : GS.t list) + : GS.t list + = let rec loop (vars : SymSet.t) (syms : Sym.t list) (stmts : GS.t list) : GS.t list = let res, stmts' = List.partition @@ -2308,17 +2338,26 @@ module Reordering = struct | _ -> "ss"); res in - let syms = get_variable_ordering iargs stmts in + let syms = get_variable_ordering rec_fsyms iargs stmts in loop iargs syms stmts - let reorder (iargs : SymSet.t) (gt : GT.t) : GT.t = + let reorder (rec_fsyms : SymSet.t) (iargs : SymSet.t) (gt : GT.t) : GT.t = let stmts, gt_last = GS.stmts_of_gt gt in - let stmts = get_statement_ordering iargs stmts in + let stmts = get_statement_ordering rec_fsyms iargs stmts in GS.gt_of_stmts stmts gt_last - let transform (gd : GD.t) : GD.t = + let transform (gtx : GD.context) (gd : GD.t) : GD.t = + let rec_fsyms = + gtx + |> List.map snd + |> List.flatten + |> List.map snd + |> List.filter_map (fun (gd' : GD.t) -> + if gd'.recursive then Some gd'.name else None) + |> SymSet.of_list + in let rec aux (iargs : SymSet.t) (gt : GT.t) : GT.t = let rec loop (iargs : SymSet.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in @@ -2336,7 +2375,7 @@ module Reordering = struct | Map ((i_sym, i_bt, it_perm), gt_inner) -> GT.map_ ((i_sym, i_bt, it_perm), aux (SymSet.add i_sym iargs) gt_inner) loc in - gt |> reorder iargs |> loop iargs + gt |> reorder rec_fsyms iargs |> loop iargs in let iargs = gd.iargs |> List.map fst |> SymSet.of_list in { gd with body = Some (aux iargs (Option.get gd.body)) } @@ -3379,7 +3418,7 @@ let optimize_gen_def (prog5 : unit Mucore.file) (passes : StringSet.t) (gd : GD. |> aux |> FlipIfs.transform |> aux - |> Reordering.transform + |> Reordering.transform [] |> ConstraintPropagation.transform |> Specialization.Equality.transform |> Specialization.Integer.transform @@ -3396,7 +3435,7 @@ let optimize let default = all_passes prog5 |> List.map (fun p -> p.name) |> StringSet.of_list in let passes = Option.value ~default passes in ctx - |> List.map_snd + (* |> List.map_snd (List.map_snd (fun ({ filename; recursive; spec; name; iargs; oargs; body } : GD.t) : GD.t -> { filename; @@ -3407,5 +3446,5 @@ let optimize oargs; body = Option.map (optimize_gen prog5 passes) body })) - |> Fusion.Recursive.transform + |> Fusion.Recursive.transform *) |> List.map_snd (List.map_snd (optimize_gen_def prog5 passes)) diff --git a/backend/cn/lib/testGeneration/genTerms.ml b/backend/cn/lib/testGeneration/genTerms.ml index 263f9eb8c..6cdce4587 100644 --- a/backend/cn/lib/testGeneration/genTerms.ml +++ b/backend/cn/lib/testGeneration/genTerms.ml @@ -359,10 +359,14 @@ let rec map_gen_post (f : t -> t) (g : t) : t = f (GT (gt_, bt, here)) -type definition = - { filename : string; - name : Sym.t; - iargs : (Sym.t * GBT.t) list; - oargs : GBT.t list; - body : t option - } +let rec contains_call (gt : t) : bool = + let (GT (gt_, _, _)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Return _ -> false + | Pick wgts -> wgts |> List.map snd |> List.exists contains_call + | Call _ -> true + | Asgn (_, _, gt_rest) -> contains_call gt_rest + | Let (_, (_, gt_inner), gt_rest) -> contains_call gt_inner || contains_call gt_rest + | Assert (_, gt_rest) -> contains_call gt_rest + | ITE (_, gt_then, gt_else) -> contains_call gt_then || contains_call gt_else + | Map (_, gt_inner) -> contains_call gt_inner From 11df0c9041b5bc5d52a91b3df9c96869ef4a82b9 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Sun, 10 Nov 2024 18:19:56 -0500 Subject: [PATCH 046/148] [CN-Test-Gen] Improve backtracking w.r.t `NULL` --- backend/cn/lib/testGeneration/genOptimize.ml | 81 ++++++++++++++++++++ runtime/libcn/include/cn-testing/dsl.h | 16 ++-- runtime/libcn/src/cn-testing/gen_alloc.c | 14 ++-- 3 files changed, 95 insertions(+), 16 deletions(-) diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 40e252b0d..f224db9f3 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -3370,6 +3370,86 @@ module Specialization = struct let iargs = gd.iargs |> List.map fst |> SymSet.of_list in { gd with body = Some (aux iargs (Option.get gd.body)) } end + + module Pointer = struct + let is_not_null (x : Sym.t) (gt : GT.t) : bool * GT.t = + let rec aux (gt : GT.t) : bool * GT.t = + let (GT (gt_, _, loc)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> (false, gt) + | Pick wgts -> + let bools, wgts' = + wgts + |> List.map_snd aux + |> List.map (fun (w, (b, gt)) -> (b, (w, gt))) + |> List.split + in + (List.fold_left ( && ) true bools, GT.pick_ wgts' loc) + | Asgn ((it_addr, sct), it_val, gt_rest) -> + let b, gt_rest' = aux gt_rest in + (b, GT.asgn_ ((it_addr, sct), it_val, gt_rest') loc) + | Let (backtracks, (x, gt_inner), gt_rest) -> + let b, gt_inner' = aux gt_inner in + let b', gt_rest' = aux gt_rest in + (b || b', GT.let_ (backtracks, (x, gt_inner'), gt_rest') loc) + | Assert + ( T + (IT + ( Unop + (Not, IT (Binop (EQ, IT (Sym y, _, _), IT (Const Null, _, _)), _, _)), + _, + _ )), + gt_rest ) + | Assert + ( T + (IT + ( Unop + (Not, IT (Binop (EQ, IT (Const Null, _, _), IT (Sym y, _, _)), _, _)), + _, + _ )), + gt_rest ) + when Sym.equal x y -> + (true, snd (aux gt_rest)) + | Assert (lc, gt_rest) -> + let b, gt_rest' = aux gt_rest in + (b, GT.assert_ (lc, gt_rest') loc) + | ITE (it_if, gt_then, gt_else) -> + let b, gt_then' = aux gt_then in + let b', gt_else' = aux gt_else in + (b || b', GT.ite_ (it_if, gt_then', gt_else') loc) + | Map ((i, i_bt, it_perm), gt_inner) -> + let b, gt_inner' = aux gt_inner in + (b, GT.map_ ((i, i_bt, it_perm), gt_inner') loc) + in + aux gt + + + let transform_gt (gt : GT.t) : GT.t = + let aux (gt : GT.t) : GT.t = + let (GT (gt_, _, loc)) = gt in + match gt_ with + | Let + ( backtracks, + (x, GT (Alloc (IT (Const (Bits (_, n)), _, _)), _, loc_size)), + gt_rest ) + when Z.equal n Z.zero -> + let not_null, gt_rest' = is_not_null x gt_rest in + if not_null then + GT.let_ + ( backtracks, + (x, GT.alloc_ (IT.num_lit_ (Z.of_int 8) Memory.size_bt loc_size) loc), + gt_rest' ) + loc + else + gt + | _ -> gt + in + GT.map_gen_pre aux gt + + + let transform (gd : GD.t) : GD.t = + { gd with body = Some (transform_gt (Option.get gd.body)) } + end end let all_passes (prog5 : unit Mucore.file) = @@ -3422,6 +3502,7 @@ let optimize_gen_def (prog5 : unit Mucore.file) (passes : StringSet.t) (gd : GD. |> ConstraintPropagation.transform |> Specialization.Equality.transform |> Specialization.Integer.transform + |> Specialization.Pointer.transform |> InferAllocationSize.transform |> aux diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index a93c181de..0c4e87bf3 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -52,8 +52,8 @@ #define CN_GEN_ASSIGN(p, offset, addr_ty, value, tmp, gen_name, last_var, ...) \ if (convert_from_cn_pointer(p) == 0) { \ - cn_gen_backtrack_assert_failure(); \ cn_gen_backtrack_relevant_add((char*)#p); \ + cn_gen_backtrack_alloc_set(8); \ goto cn_label_##last_var##_backtrack; \ } \ void *tmp##_ptr = convert_from_cn_pointer(cn_pointer_add_cn_bits_u64(p, offset)); \ @@ -76,11 +76,11 @@ #define CN_GEN_LET_BEGIN(backtracks, var) \ int var##_backtracks = backtracks; \ + alloc_checkpoint var##_checkpoint = alloc_save_checkpoint(); \ + void *var##_alloc_checkpoint = cn_gen_alloc_save(); \ + void *var##_ownership_checkpoint = cn_gen_ownership_save(); \ cn_label_##var##_gen: \ ; \ - alloc_checkpoint var##_checkpoint = alloc_save_checkpoint(); \ - void *var##_alloc_checkpoint = cn_gen_alloc_save(); \ - void *var##_ownership_checkpoint = cn_gen_ownership_save(); #define CN_GEN_LET_BODY(ty, var, gen) \ ty* var = gen; \ @@ -92,9 +92,6 @@ free_after(var##_checkpoint); \ cn_gen_alloc_restore(var##_alloc_checkpoint); \ cn_gen_ownership_restore(var##_ownership_checkpoint); \ - if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ALLOC) { \ - cn_gen_rand_restore(var##_rand_checkpoint); \ - } \ if (cn_gen_backtrack_relevant_contains((char*)#var)) { \ char *toAdd[] = { __VA_ARGS__ }; \ cn_gen_backtrack_relevant_add_many(toAdd); \ @@ -109,6 +106,7 @@ if (toAdd[0] != NULL) { \ goto cn_label_##last_var##_backtrack; \ } \ + cn_gen_rand_restore(var##_rand_checkpoint); \ } \ goto cn_label_##var##_gen; \ } else { \ @@ -162,11 +160,11 @@ } \ tmp##_num_choices /= 2; \ struct cn_gen_int_urn* tmp##_urn = urn_from_array(tmp##_choices, tmp##_num_choices);\ - cn_label_##tmp##_gen: \ - ; \ alloc_checkpoint tmp##_checkpoint = alloc_save_checkpoint(); \ void *tmp##_alloc_checkpoint = cn_gen_alloc_save(); \ void *tmp##_ownership_checkpoint = cn_gen_ownership_save(); \ + cn_label_##tmp##_gen: \ + ; \ uint64_t tmp = urn_remove(tmp##_urn); \ if (0) { \ cn_label_##tmp##_backtrack: \ diff --git a/runtime/libcn/src/cn-testing/gen_alloc.c b/runtime/libcn/src/cn-testing/gen_alloc.c index a8b4add0b..dfc17670e 100644 --- a/runtime/libcn/src/cn-testing/gen_alloc.c +++ b/runtime/libcn/src/cn-testing/gen_alloc.c @@ -69,18 +69,18 @@ cn_pointer* cn_gen_alloc(cn_bits_u64* sz) { bytes = cn_gen_backtrack_alloc_get(); cn_gen_backtrack_reset(); } - - if (bytes == 0) { - void* p; + else if (bytes == 0) { uint64_t rnd = convert_from_cn_bits_u8(cn_gen_uniform_cn_bits_u8(null_in_every)); if (rnd == 0) { - p = NULL; + bytes = 0; } else { - p = alloc(1); - update_alloc(p, 1); + bytes = 8; } - return convert_to_cn_pointer(p); + } + + if (bytes == 0) { + return convert_to_cn_pointer(NULL); } else { void* p = alloc(bytes); From 75dce8cb3ecc8e19ff098dc36d10bc09b7f9963c Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Sun, 10 Nov 2024 19:57:10 -0500 Subject: [PATCH 047/148] [CN-Test-Gen] Sized generators --- backend/cn/bin/main.ml | 13 +- backend/cn/lib/testGeneration/genAnalysis.ml | 34 ++ backend/cn/lib/testGeneration/genCodeGen.ml | 110 +++-- backend/cn/lib/testGeneration/genInline.ml | 11 +- backend/cn/lib/testGeneration/genRuntime.ml | 108 ++++- backend/cn/lib/testGeneration/genRuntime.mli | 9 +- backend/cn/lib/testGeneration/specTests.ml | 5 + .../cn/lib/testGeneration/testGenConfig.ml | 10 +- .../cn/lib/testGeneration/testGenConfig.mli | 7 +- runtime/libcn/dune | 2 + runtime/libcn/include/cn-testing/alloc.h | 7 +- runtime/libcn/include/cn-testing/backtrack.h | 6 - runtime/libcn/include/cn-testing/dsl.h | 50 ++- runtime/libcn/include/cn-testing/prelude.h | 1 + runtime/libcn/include/cn-testing/size.h | 14 + runtime/libcn/include/cn-testing/test.h | 3 + runtime/libcn/src/cn-testing/backtrack.c | 23 - runtime/libcn/src/cn-testing/gen_alloc.c | 20 +- runtime/libcn/src/cn-testing/size.c | 44 ++ runtime/libcn/src/cn-testing/test.c | 15 +- tests/cn-test-gen/src/bin_tree.pass.c | 45 ++ tests/cn-test-gen/src/bst.fail.c | 405 ++++++++++++++++++ tests/cn-test-gen/src/bst.pass.c | 2 +- 23 files changed, 857 insertions(+), 87 deletions(-) create mode 100644 runtime/libcn/include/cn-testing/size.h create mode 100644 runtime/libcn/src/cn-testing/size.c create mode 100644 tests/cn-test-gen/src/bin_tree.pass.c create mode 100644 tests/cn-test-gen/src/bst.fail.c diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 591f7c5de..60fb8a3c1 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -445,6 +445,7 @@ let run_tests until_timeout exit_fast max_stack_depth + max_generator_size = (* flags *) Cerb_debug.debug_level := debug_level; @@ -507,7 +508,8 @@ let run_tests interactive; until_timeout; exit_fast; - max_stack_depth + max_stack_depth; + max_generator_size } in TestGeneration.run @@ -959,6 +961,14 @@ module Testing_flags = struct value & opt (some int) TestGeneration.default_cfg.max_stack_depth & info [ "max-stack-depth" ] ~doc) + + + let test_max_generator_size = + let doc = "Maximum size for generated values" in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.max_generator_size + & info [ "max-generator-size" ] ~doc) end let testing_cmd = @@ -990,6 +1000,7 @@ let testing_cmd = $ Testing_flags.test_until_timeout $ Testing_flags.test_exit_fast $ Testing_flags.test_max_stack_depth + $ Testing_flags.test_max_generator_size in let doc = "Generates RapidCheck tests for all functions in [FILE] with CN specifications.\n\ diff --git a/backend/cn/lib/testGeneration/genAnalysis.ml b/backend/cn/lib/testGeneration/genAnalysis.ml index 38e2feaa0..1ef576586 100644 --- a/backend/cn/lib/testGeneration/genAnalysis.ml +++ b/backend/cn/lib/testGeneration/genAnalysis.ml @@ -6,6 +6,7 @@ module LC = LogicalConstraints module RP = ResourcePredicates module LAT = LogicalArgumentTypes module GT = GenTerms +module GD = GenDefinitions module SymSet = Set.Make (Sym) module SymMap = Map.Make (Sym) @@ -209,3 +210,36 @@ let get_recursive_preds (preds : (Sym.t * RP.definition) list) : SymSet.t = |> List.map fst |> List.filter (fun fsym -> G.mem_edge closure fsym fsym) |> SymSet.of_list + + +module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) + +open struct + let get_calls (gd : GD.t) : SymSet.t = + let rec aux (gt : GT.t) : SymSet.t = + let (GT (gt_, _, _)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Return _ -> SymSet.empty + | Pick wgts -> + wgts |> List.map snd |> List.map aux |> List.fold_left SymSet.union SymSet.empty + | Call (fsym, _) -> SymSet.singleton fsym + | Asgn (_, _, gt') | Assert (_, gt') | Map (_, gt') -> aux gt' + | Let (_, (_, gt1), gt2) | ITE (_, gt1, gt2) -> SymSet.union (aux gt1) (aux gt2) + in + aux (Option.get gd.body) + + + module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) + module Oper = Graph.Oper.P (SymGraph) +end + +let get_call_graph (ctx : GD.context) : SymGraph.t = + ctx + |> List.map_snd (List.map snd) + |> List.map_snd (fun gds -> match gds with [ gd ] -> gd | _ -> failwith __LOC__) + |> List.map_snd get_calls + |> List.fold_left + (fun cg (fsym, calls) -> + SymSet.fold (fun fsym' cg' -> SymGraph.add_edge cg' fsym fsym') calls cg) + SymGraph.empty + |> Oper.transitive_closure diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index c4b2faa09..e9cea8c0c 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -47,6 +47,7 @@ let compile_lc (sigma : CF.GenTypes.genTypeCategory A.sigma) (lc : LC.t) = let rec compile_term (sigma : CF.GenTypes.genTypeCategory A.sigma) + (ctx : GR.context) (name : Sym.t) (tm : GR.term) : A.bindings @@ -55,25 +56,22 @@ let rec compile_term = let loc = Locations.other __LOC__ in match tm with - | Uniform { bt; sz } -> + | Uniform { bt; sz = _ } -> ( [], [], A.( mk_expr (AilEcall ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_UNIFORM")), - List.map - mk_expr - [ AilEident (Sym.fresh_named (name_of_bt name bt)); - AilEconst (ConstantInteger (IConstant (Z.of_int sz, Decimal, None))) - ] ))) ) + List.map mk_expr [ AilEident (Sym.fresh_named (name_of_bt name bt)) ] ))) + ) | Pick { bt; choice_var; choices; last_var } -> let var = Sym.fresh () in let bs, ss = List.split (List.mapi (fun i (_, gr) -> - let bs, ss, e = compile_term sigma name gr in + let bs, ss, e = compile_term sigma ctx name gr in ( bs, A.( [ AilSexpr @@ -131,13 +129,48 @@ let rec compile_term [ mk_expr (AilEident choice_var) ] ))) ], A.(mk_expr (AilEident var)) ) - | Alloc { bytes = it } -> - let alloc_sym = Sym.fresh_named "cn_gen_alloc" in + | Alloc { bytes = it; sized } -> + let alloc_sym = + Sym.fresh_named (if sized then "CN_GEN_ALLOC_SIZED" else "CN_GEN_ALLOC") + in let b, s, e = compile_it sigma name it in - (b, s, mk_expr (AilEcall (mk_expr (AilEident alloc_sym), [ e ]))) - | Call { fsym; iargs; oarg_bt; path_vars } -> + let es = + if sized then + [ e; mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")) ] + else + [ e ] + in + (b, s, mk_expr (AilEcall (mk_expr (AilEident alloc_sym), es))) + | Call { fsym; iargs; oarg_bt; path_vars; sized } -> let sym = GenUtils.get_mangled_name (fsym :: List.map fst iargs) in - let es = iargs |> List.map snd |> List.map (fun x -> A.(mk_expr (AilEident x))) in + let es = iargs |> List.map snd |> List.map (fun x -> A.(AilEident x)) in + let es = + List.map + mk_expr + (es + @ A.( + match sized with + | Some 1 -> + [ AilEbinary + ( mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")), + Arithmetic Sub, + mk_expr + (AilEconst (ConstantInteger (IConstant (Z.one, Decimal, None)))) ) + ] + | Some n -> + [ AilEbinary + ( mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")), + Arithmetic Div, + mk_expr + (AilEconst + (ConstantInteger (IConstant (Z.of_int n, Decimal, None)))) ) + ] + | None + when (not (GenBuiltins.is_builtin fsym)) + && (ctx |> List.assoc Sym.equal fsym |> List.hd |> snd).sized -> + [ AilEcall (mk_expr (AilEident (Sym.fresh_named "cn_gen_get_size")), []) ] + | None -> [])) + in let x = Sym.fresh () in let b = Utils.create_binding x (bt_to_ctype fsym oarg_bt) in let wrap_to_string (sym : Sym.t) = @@ -232,7 +265,7 @@ let rec compile_term @ [ mk_expr (AilEconst ConstantNull) ] ))) ] in - let b4, s4, e4 = compile_term sigma name rest in + let b4, s4, e4 = compile_term sigma ctx name rest in (b1 @ b2 @ b3 @ b4, s1 @ s2 @ s3 @ s4, e4) | Let { backtracks; x; x_bt; value; last_var; rest } -> let s1 = @@ -250,7 +283,7 @@ let rec compile_term ] ))) ] in - let b2, s2, e2 = compile_term sigma name value in + let b2, s2, e2 = compile_term sigma ctx name value in let s3 = A.( [ AilSexpr @@ -265,7 +298,13 @@ let rec compile_term (Option.value ~default:name (match value with - | Call { fsym; iargs; oarg_bt = _; path_vars = _ } -> + | Call + { fsym; + iargs; + oarg_bt = _; + path_vars = _; + sized = _ + } -> Some (GenUtils.get_mangled_name (fsym :: List.map fst iargs)) @@ -302,7 +341,7 @@ let rec compile_term @ [ mk_expr (AilEconst ConstantNull) ] ))) ]) in - let b4, s4, e4 = compile_term sigma name rest in + let b4, s4, e4 = compile_term sigma ctx name rest in (b2 @ [ Utils.create_binding x (bt_to_ctype name x_bt) ] @ b4, s1 @ s2 @ s3 @ s4, e4) | Return { value } -> let b, s, e = compile_it sigma name value in @@ -332,12 +371,12 @@ let rec compile_term @ [ mk_expr (AilEconst ConstantNull) ] ))) ] in - let b2, s2, e2 = compile_term sigma name rest in + let b2, s2, e2 = compile_term sigma ctx name rest in (b1 @ b2, s1 @ s_assert @ s2, e2) | ITE { bt; cond; t; f } -> let b_if, s_if, e_if = compile_it sigma name cond in - let b_then, s_then, e_then = compile_term sigma name t in - let b_else, s_else, e_else = compile_term sigma name f in + let b_then, s_then, e_then = compile_term sigma ctx name t in + let b_else, s_else, e_else = compile_term sigma ctx name f in let res_sym = Sym.fresh () in let res_expr = mk_expr (AilEident res_sym) in let res_binding = Utils.create_binding res_sym (bt_to_ctype name bt) in @@ -406,7 +445,7 @@ let rec compile_term (mk_expr (AilEident (Sym.fresh_named "CN_GEN_MAP_BODY")), [ e_perm ]))) ]) in - let b_val, s_val, e_val = compile_term sigma name inner in + let b_val, s_val, e_val = compile_term sigma ctx name inner in let s_end = A.( s_val @@ -424,6 +463,7 @@ let rec compile_term let compile_gen_def (sigma : CF.GenTypes.genTypeCategory A.sigma) + (ctx : GR.context) ((name, gr) : Sym.t * GR.definition) : A.sigma_tag_definition * (A.sigma_declaration * 'a A.sigma_function_definition) = @@ -437,7 +477,12 @@ let compile_gen_def A.Decl_function ( false, (C.no_qualifiers, ct_ret), - List.map (fun (_, bt) -> (C.no_qualifiers, bt_to_ctype name bt, false)) gr.iargs, + (List.map (fun (_, bt) -> (C.no_qualifiers, bt_to_ctype name bt, false)) gr.iargs + @ + if gr.sized then + [ (C.no_qualifiers, C.mk_ctype_integer Size_t, false) ] + else + []), false, false, false ) @@ -446,15 +491,26 @@ let compile_gen_def let s1 = A.( AilSexpr - (mk_expr (AilEcall (mk_expr (AilEident (Sym.fresh_named "CN_GEN_INIT")), [])))) + (mk_expr + (if gr.sized then + AilEcall + ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_INIT_SIZED")), + [ mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")) ] ) + else + AilEcall (mk_expr (AilEident (Sym.fresh_named "CN_GEN_INIT")), [])))) in - let b2, s2, e2 = compile_term sigma name gr.body in + let b2, s2, e2 = compile_term sigma ctx name gr.body in let sigma_def : CF.GenTypes.genTypeCategory A.sigma_function_definition = ( name, ( loc, 0, CF.Annot.Attrs [], - List.map fst gr.iargs, + (List.map fst gr.iargs + @ + if gr.sized then + [ Sym.fresh_named "cn_gen_rec_size" ] + else + []), mk_stmt (A.AilSblock ( b2, @@ -467,9 +523,7 @@ let compile_gen_def (mk_expr (AilEcall ( mk_expr - (AilEident - (Sym.fresh_named - "cn_gen_backtrack_decrement_depth")), + (AilEident (Sym.fresh_named "cn_gen_decrement_depth")), [] ))) ] @ A. @@ -504,7 +558,7 @@ let compile (sigma : CF.GenTypes.genTypeCategory A.sigma) (ctx : GR.context) : P BT.Record (List.map (fun (x, bt) -> (Id.id (Sym.pp_string x), bt)) def.oargs) in CtA.augment_record_map ~cn_sym:name bt); - let tag_definitions, funcs = List.split (List.map (compile_gen_def sigma) defs) in + let tag_definitions, funcs = List.split (List.map (compile_gen_def sigma ctx) defs) in let declarations, function_definitions = List.split funcs in let sigma : 'a A.sigma = { A.empty_sigma with tag_definitions; declarations; function_definitions } diff --git a/backend/cn/lib/testGeneration/genInline.ml b/backend/cn/lib/testGeneration/genInline.ml index f23af0f14..fd41a0154 100644 --- a/backend/cn/lib/testGeneration/genInline.ml +++ b/backend/cn/lib/testGeneration/genInline.ml @@ -29,7 +29,16 @@ let unfold (ctx : GD.context) : GD.context = else loop (Option.map (fun x -> x - 1) fuel) { gd with body = Some gt' }) in - List.map_snd (List.map_snd (loop (TestGenConfig.get_max_unfolds ()))) ctx + let unfolds = TestGenConfig.get_max_unfolds () in + ctx + |> List.map_snd (List.map_snd (loop unfolds)) + |> List.filter_map (fun (x, gds) -> + if Option.is_some unfolds then + Some (x, gds) + else ( + match List.filter (fun ((_, gd) : _ * GD.t) -> gd.spec || gd.recursive) gds with + | [] -> None + | gds' -> Some (x, gds'))) let inline (ctx : GD.context) : GD.context = unfold ctx diff --git a/backend/cn/lib/testGeneration/genRuntime.ml b/backend/cn/lib/testGeneration/genRuntime.ml index 60da94dcb..461eb328e 100644 --- a/backend/cn/lib/testGeneration/genRuntime.ml +++ b/backend/cn/lib/testGeneration/genRuntime.ml @@ -8,6 +8,7 @@ module GD = GenDefinitions module GBT = GenBaseTypes module GA = GenAnalysis module SymSet = Set.Make (Sym) +module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) module StringMap = Map.Make (String) let bennet = Sym.fresh_named "bennet" @@ -23,12 +24,16 @@ type term = choices : (int * term) list; last_var : Sym.t } - | Alloc of { bytes : IT.t } + | Alloc of + { bytes : IT.t; + sized : bool + } | Call of { fsym : Sym.t; iargs : (Sym.t * Sym.t) list; oarg_bt : BT.t; - path_vars : SymSet.t + path_vars : SymSet.t; + sized : int option } | Asgn of { pointer : Sym.t; @@ -76,8 +81,8 @@ let rec free_vars_term (tm : term) : SymSet.t = | Uniform _ -> SymSet.empty | Pick { bt = _; choice_var = _; choices; last_var = _ } -> free_vars_term_list (List.map snd choices) - | Alloc { bytes } -> IT.free_vars bytes - | Call { fsym = _; iargs; oarg_bt = _; path_vars = _ } -> + | Alloc { bytes; sized = _ } -> IT.free_vars bytes + | Call { fsym = _; iargs; oarg_bt = _; path_vars = _; sized = _ } -> SymSet.of_list (List.map snd iargs) | Asgn { pointer; offset; sct = _; value; last_var = _; rest } -> List.fold_left @@ -133,10 +138,12 @@ let rec pp_term (tm : term) : Pp.document = parens (int w ^^ comma ^^ braces (nest 2 (break 1 ^^ pp_term gt)))) choices))) - | Alloc { bytes } -> string "alloc" ^^ parens (IT.pp bytes) - | Call { fsym; iargs; oarg_bt; path_vars } -> + | Alloc { bytes; sized } -> + (if sized then string "alloc_sized" else string "alloc") ^^ parens (IT.pp bytes) + | Call { fsym; iargs; oarg_bt; path_vars; sized } -> parens (Sym.pp fsym + ^^ optional (fun n -> brackets (int n)) sized ^^ parens (nest 2 @@ -361,7 +368,7 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = List.map (fun (w, gt) -> (f w, aux (choice_var :: vars) path_vars gt)) wgts); last_var } - | Alloc bytes -> Alloc { bytes } + | Alloc bytes -> Alloc { bytes; sized = false } | Call (fsym, xits) -> let (iargs : (Sym.t * Sym.t) list), (gt_lets : Sym.t -> term -> term) = List.fold_right @@ -384,7 +391,7 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = xits ([], fun _ gr -> gr) in - gt_lets last_var (Call { fsym; iargs; oarg_bt = bt; path_vars }) + gt_lets last_var (Call { fsym; iargs; oarg_bt = bt; path_vars; sized = None }) | Asgn ((it_addr, sct), value, rest) -> let pointer, offset = GA.get_addr_offset it_addr in if not (SymSet.mem pointer inputs || List.exists (Sym.equal pointer) vars) then @@ -426,6 +433,7 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = type definition = { filename : string; + sized : bool; name : Sym.t; iargs : (Sym.t * BT.t) list; oargs : (Sym.t * BT.t) list; @@ -457,10 +465,11 @@ let pp_definition (def : definition) : Pp.document = ^^ rbrace) -let elaborate_gd ({ filename; recursive = _; spec = _; name; iargs; oargs; body } : GD.t) +let elaborate_gd ({ filename; recursive; spec = _; name; iargs; oargs; body } : GD.t) : definition = { filename; + sized = recursive; name; iargs = List.map_snd GBT.bt iargs; oargs = List.map_snd GBT.bt oargs; @@ -484,4 +493,83 @@ let pp (ctx : context) : Pp.document = defns -let elaborate (gtx : GD.context) : context = List.map_snd (List.map_snd elaborate_gd) gtx +module Sizing = struct + let count_recursive_calls (syms : SymSet.t) (gr : term) : int = + let rec aux (gr : term) : int = + match gr with + | Uniform _ | Alloc _ | Return _ -> 0 + | Pick { choices; _ } -> + choices |> List.map snd |> List.map aux |> List.fold_left max 0 + | Call { fsym; _ } -> if SymSet.mem fsym syms then 1 else 0 + | Asgn { rest; _ } -> aux rest + | Let { value; rest; _ } -> aux value + aux rest + | Assert { rest; _ } -> aux rest + | ITE { t; f; _ } -> max (aux t) (aux f) + | Map { inner; _ } -> aux inner + in + aux gr + + + let size_recursive_calls (syms : SymSet.t) (size : int) (gr : term) : term = + let rec aux (gr : term) : term = + match gr with + | Call ({ fsym; _ } as gr) when SymSet.mem fsym syms -> + Call { gr with sized = Some size } + | Uniform _ | Call _ | Return _ -> gr + | Alloc { bytes; sized = _ } -> Alloc { bytes; sized = true } + | Pick ({ choices; _ } as gr) -> + Pick { gr with choices = choices |> List.map_snd aux } + | Asgn ({ rest; _ } as gr) -> Asgn { gr with rest = aux rest } + | Let ({ value; rest; _ } as gr) -> + Let { gr with value = aux value; rest = aux rest } + | Assert ({ rest; _ } as gr) -> Assert { gr with rest = aux rest } + | ITE ({ t; f; _ } as gr) -> ITE { gr with t = aux t; f = aux f } + | Map ({ inner; _ } as gr) -> Map { gr with inner = aux inner } + in + aux gr + + + let transform_gr (syms : SymSet.t) (gr : term) : term = + let rec aux (gr : term) : term = + match gr with + | ITE { bt; cond; t; f } -> ITE { bt; cond; t = aux t; f = aux f } + | Pick { bt; choice_var; choices; last_var } -> + Pick { bt; choice_var; choices = List.map_snd aux choices; last_var } + | _ -> + let count = count_recursive_calls syms gr in + size_recursive_calls syms count gr + in + aux gr + + + let transform_def + (cg : SymGraph.t) + ({ filename : string; + sized : bool; + name : SymSet.elt; + iargs : (SymSet.elt * BT.t) list; + oargs : (SymSet.elt * BT.t) list; + body : term + } : + definition) + : definition + = + { filename; + sized; + name; + iargs; + oargs; + body = transform_gr (SymGraph.fold_pred SymSet.add cg name SymSet.empty) body + } + + + let transform (cg : SymGraph.t) (ctx : context) : context = + List.map_snd + (List.map_snd (fun ({ sized; _ } as def) -> + if sized then transform_def cg def else def)) + ctx +end + +let elaborate (gtx : GD.context) : context = + let cg = GA.get_call_graph gtx in + gtx |> List.map_snd (List.map_snd elaborate_gd) |> Sizing.transform cg diff --git a/backend/cn/lib/testGeneration/genRuntime.mli b/backend/cn/lib/testGeneration/genRuntime.mli index 7147ef4b8..a81960aa8 100644 --- a/backend/cn/lib/testGeneration/genRuntime.mli +++ b/backend/cn/lib/testGeneration/genRuntime.mli @@ -18,12 +18,16 @@ type term = choices : (int * term) list; last_var : Sym.t } - | Alloc of { bytes : IT.t } + | Alloc of + { bytes : IT.t; + sized : bool + } | Call of { fsym : Sym.t; iargs : (Sym.t * Sym.t) list; oarg_bt : BT.t; - path_vars : SymSet.t + path_vars : SymSet.t; + sized : int option } | Asgn of { pointer : Sym.t; @@ -72,6 +76,7 @@ val pp_term : term -> Pp.document type definition = { filename : string; + sized : bool; name : Sym.t; iargs : (Sym.t * BT.t) list; oargs : (Sym.t * BT.t) list; diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 7a6ab9dec..78127e685 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -458,6 +458,11 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = |> Option.map (fun max_stack_depth -> [ "--max-stack-depth"; string_of_int max_stack_depth ]) |> Option.to_list + |> List.flatten) + @ (Config.has_max_generator_size () + |> Option.map (fun max_generator_size -> + [ "--max-generator-size"; string_of_int max_generator_size ]) + |> Option.to_list |> List.flatten)) in string "if" diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index 463fdd9b7..94521760b 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -11,7 +11,8 @@ type t = interactive : bool; until_timeout : int option; exit_fast : bool; - max_stack_depth : int option + max_stack_depth : int option; + max_generator_size : int option } let default = @@ -25,7 +26,8 @@ let default = interactive = false; until_timeout = None; exit_fast = false; - max_stack_depth = None + max_stack_depth = None; + max_generator_size = None } @@ -33,6 +35,8 @@ let instance = ref default let initialize (cfg : t) = instance := cfg +let get_num_samples () = !instance.num_samples + let get_max_backtracks () = !instance.max_backtracks let get_max_unfolds () = !instance.max_unfolds @@ -53,4 +57,4 @@ let is_exit_fast () = !instance.exit_fast let has_max_stack_depth () = !instance.max_stack_depth -let get_num_samples () = !instance.num_samples +let has_max_generator_size () = !instance.max_generator_size diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 0ccc572be..e5a52341e 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -11,13 +11,16 @@ type t = interactive : bool; until_timeout : int option; exit_fast : bool; - max_stack_depth : int option + max_stack_depth : int option; + max_generator_size : int option } val default : t val initialize : t -> unit +val get_num_samples : unit -> int + val get_max_backtracks : unit -> int val get_max_unfolds : unit -> int option @@ -38,4 +41,4 @@ val is_exit_fast : unit -> bool val has_max_stack_depth : unit -> int option -val get_num_samples : unit -> int +val has_max_generator_size : unit -> int option diff --git a/runtime/libcn/dune b/runtime/libcn/dune index 6f31560f0..3b2076aa3 100644 --- a/runtime/libcn/dune +++ b/runtime/libcn/dune @@ -24,6 +24,7 @@ uniform.o urn.o rand.o + size.o test.o)))) (install @@ -38,6 +39,7 @@ (include/cn-testing/uniform.h as runtime/include/cn-testing/uniform.h) (include/cn-testing/urn.h as runtime/include/cn-testing/urn.h) (include/cn-testing/rand.h as runtime/include/cn-testing/rand.h) + (include/cn-testing/size.h as runtime/include/cn-testing/size.h) (include/cn-testing/dsl.h as runtime/include/cn-testing/dsl.h) (include/cn-testing/result.h as runtime/include/cn-testing/result.h) (include/cn-testing/test.h as runtime/include/cn-testing/test.h) diff --git a/runtime/libcn/include/cn-testing/alloc.h b/runtime/libcn/include/cn-testing/alloc.h index 0b25fd38a..25cd2611e 100644 --- a/runtime/libcn/include/cn-testing/alloc.h +++ b/runtime/libcn/include/cn-testing/alloc.h @@ -9,12 +9,15 @@ extern "C" { #endif + uint8_t get_null_in_every(void); void set_null_in_every(uint8_t n); - void cn_gen_alloc_reset(void); + int is_sized_null(void); + void set_sized_null(void); + void unset_sized_null(void); + void cn_gen_alloc_reset(void); void* cn_gen_alloc_save(void); - void cn_gen_alloc_restore(void* ptr); void cn_gen_ownership_reset(void); diff --git a/runtime/libcn/include/cn-testing/backtrack.h b/runtime/libcn/include/cn-testing/backtrack.h index ed55a6d69..5185ce4f9 100644 --- a/runtime/libcn/include/cn-testing/backtrack.h +++ b/runtime/libcn/include/cn-testing/backtrack.h @@ -4,12 +4,6 @@ #include #include -uint16_t cn_gen_backtrack_depth(); -uint16_t cn_gen_backtrack_max_depth(); -void cn_gen_backtrack_set_max_depth(uint16_t msd); -void cn_gen_backtrack_increment_depth(); -void cn_gen_backtrack_decrement_depth(); - enum cn_gen_backtrack_request { CN_GEN_BACKTRACK_NONE, CN_GEN_BACKTRACK_ASSERT, diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index 0c4e87bf3..a02ddabd6 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -10,16 +10,54 @@ #define CN_GEN_INIT() \ if (0) { \ cn_label_bennet_backtrack: \ - cn_gen_backtrack_decrement_depth(); \ + cn_gen_decrement_depth(); \ return NULL; \ } \ - cn_gen_backtrack_increment_depth(); \ - if (cn_gen_backtrack_depth() == cn_gen_backtrack_max_depth()) { \ + cn_gen_increment_depth(); \ + if (cn_gen_depth() == cn_gen_max_depth()) { \ cn_gen_backtrack_depth_exceeded(); \ goto cn_label_bennet_backtrack; \ } -#define CN_GEN_UNIFORM(ty, sz) cn_gen_uniform_##ty(sz) +#define CN_GEN_INIT_SIZED(size) \ + if (0) { \ + cn_label_bennet_backtrack: \ + cn_gen_decrement_depth(); \ + return NULL; \ + } \ + cn_gen_increment_depth(); \ + if (size <= 0 || cn_gen_depth() == cn_gen_max_depth()) { \ + static int backtracks; \ + backtracks++; \ + if (backtracks >= 100) { \ + cn_gen_backtrack_assert_failure(); \ + goto cn_label_bennet_backtrack; \ + } \ + cn_gen_backtrack_depth_exceeded(); \ + goto cn_label_bennet_backtrack; \ + } + +#define CN_GEN_UNIFORM(ty) cn_gen_uniform_##ty(cn_gen_get_size()) + +#define CN_GEN_ALLOC(sz) CN_GEN_ALLOC_SIZED(sz, cn_gen_get_size()) + +#define CN_GEN_ALLOC_SIZED(sz, gen_size) \ + ({ \ + cn_pointer *ptr; \ + uint8_t null_in_every = get_null_in_every(); \ + if (is_sized_null()) { \ + set_null_in_every(gen_size); \ + } \ + if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_ALLOC && gen_size <= 2) { \ + ptr = convert_to_cn_pointer(NULL); \ + } else { \ + ptr = cn_gen_alloc(sz); \ + } \ + if (is_sized_null()) { \ + set_null_in_every(null_in_every); \ + } \ + ptr; \ + }) #define CN_GEN_LT_(ty, max) cn_gen_lt_##ty(max) @@ -106,7 +144,9 @@ if (toAdd[0] != NULL) { \ goto cn_label_##last_var##_backtrack; \ } \ - cn_gen_rand_restore(var##_rand_checkpoint); \ + if (cn_gen_backtrack_alloc_get() > 0) { \ + cn_gen_rand_restore(var##_rand_checkpoint); \ + } \ } \ goto cn_label_##var##_gen; \ } else { \ diff --git a/runtime/libcn/include/cn-testing/prelude.h b/runtime/libcn/include/cn-testing/prelude.h index 870e9d9cf..77dbeea7d 100644 --- a/runtime/libcn/include/cn-testing/prelude.h +++ b/runtime/libcn/include/cn-testing/prelude.h @@ -7,6 +7,7 @@ #include #include #include +#include #include #include diff --git a/runtime/libcn/include/cn-testing/size.h b/runtime/libcn/include/cn-testing/size.h new file mode 100644 index 000000000..55b645c96 --- /dev/null +++ b/runtime/libcn/include/cn-testing/size.h @@ -0,0 +1,14 @@ +#include +#include + +size_t cn_gen_get_size(void); +void cn_gen_set_size(size_t sz); + +size_t cn_gen_get_max_size(void); +void cn_gen_set_max_size(size_t sz); + +uint16_t cn_gen_depth(); +uint16_t cn_gen_max_depth(); +void cn_gen_set_max_depth(uint16_t msd); +void cn_gen_increment_depth(); +void cn_gen_decrement_depth(); diff --git a/runtime/libcn/include/cn-testing/test.h b/runtime/libcn/include/cn-testing/test.h index 9691d6df4..5f07897db 100644 --- a/runtime/libcn/include/cn-testing/test.h +++ b/runtime/libcn/include/cn-testing/test.h @@ -3,6 +3,7 @@ #include #include +#include #include typedef enum cn_test_result cn_test_case_fn(int); @@ -59,6 +60,8 @@ void print_test_info(char* suite, char* name, int tests, int discards); return CN_TEST_GEN_FAIL; \ } \ cn_gen_rand_replace(checkpoint); \ + size_t sz = cn_gen_uniform_cn_bits_u16(cn_gen_get_max_size())->val + 1; \ + cn_gen_set_size(sz); \ CN_TEST_INIT(); \ struct cn_gen_##Name##_record *res = cn_gen_##Name(); \ if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ diff --git a/runtime/libcn/src/cn-testing/backtrack.c b/runtime/libcn/src/cn-testing/backtrack.c index 2cd109e9d..4c4b7bd2c 100644 --- a/runtime/libcn/src/cn-testing/backtrack.c +++ b/runtime/libcn/src/cn-testing/backtrack.c @@ -2,29 +2,6 @@ #include -static uint16_t stack_depth = 0; -static uint16_t max_stack_depth = UINT8_MAX; - -uint16_t cn_gen_backtrack_depth() { - return stack_depth; -} - -uint16_t cn_gen_backtrack_max_depth() { - return max_stack_depth; -} - -void cn_gen_backtrack_set_max_depth(uint16_t msd) { - max_stack_depth = msd; -} - -void cn_gen_backtrack_increment_depth() { - stack_depth++; -} - -void cn_gen_backtrack_decrement_depth() { - stack_depth--; -} - static enum cn_gen_backtrack_request type = CN_GEN_BACKTRACK_NONE; diff --git a/runtime/libcn/src/cn-testing/gen_alloc.c b/runtime/libcn/src/cn-testing/gen_alloc.c index dfc17670e..789e91c38 100644 --- a/runtime/libcn/src/cn-testing/gen_alloc.c +++ b/runtime/libcn/src/cn-testing/gen_alloc.c @@ -57,12 +57,30 @@ static void update_ownership(void* ptr, size_t sz) { ownership_curr = (char*)ownership_curr + sizeof(struct pointer_data); } -static uint8_t null_in_every = 4; +static uint8_t null_in_every = 5; + +uint8_t get_null_in_every(void) { + return null_in_every; +} void set_null_in_every(uint8_t n) { null_in_every = n; } +static int sized_null = 0; + +int is_sized_null(void) { + return sized_null; +} + +void set_sized_null(void) { + sized_null = 1; +} + +void unset_sized_null(void) { + sized_null = 0; +} + cn_pointer* cn_gen_alloc(cn_bits_u64* sz) { uint64_t bytes = convert_from_cn_bits_u64(sz); if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ALLOC) { diff --git a/runtime/libcn/src/cn-testing/size.c b/runtime/libcn/src/cn-testing/size.c new file mode 100644 index 000000000..3e459e2a2 --- /dev/null +++ b/runtime/libcn/src/cn-testing/size.c @@ -0,0 +1,44 @@ +#include + +static size_t global_size = 20; + +size_t cn_gen_get_size(void) { + return global_size; +} + +void cn_gen_set_size(size_t sz) { + global_size = sz; +} + +static size_t global_max_size = 25; + +size_t cn_gen_get_max_size(void) { + return global_max_size; +} + +void cn_gen_set_max_size(size_t sz) { + global_max_size = sz; +} + +static uint16_t stack_depth = 0; +static uint16_t max_stack_depth = UINT8_MAX; + +uint16_t cn_gen_depth() { + return stack_depth; +} + +uint16_t cn_gen_max_depth() { + return max_stack_depth; +} + +void cn_gen_set_max_depth(uint16_t msd) { + max_stack_depth = msd; +} + +void cn_gen_increment_depth() { + stack_depth++; +} + +void cn_gen_decrement_depth() { + stack_depth--; +} \ No newline at end of file diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index 487ccb389..0111ad01f 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -5,6 +5,7 @@ #include #include #include +#include #include @@ -12,7 +13,7 @@ #include #include #include -#include +#include struct cn_test_case { char* suite; @@ -88,7 +89,17 @@ int cn_test_main(int argc, char* argv[]) { exit_fast = 1; } else if (strcmp("--max-stack-depth", arg) == 0) { - cn_gen_backtrack_set_max_depth(strtoul(argv[i + 1], NULL, 10)); + cn_gen_set_max_depth(strtoul(argv[i + 1], NULL, 10)); + i++; + } + else if (strcmp("--max-generator-size", arg) == 0) { + uint64_t sz = strtoul(argv[i + 1], NULL, 10); + assert(sz != 0); + cn_gen_set_max_size(sz); + i++; + } + else if (strcmp("--sized-null", arg) == 0) { + set_sized_null(); i++; } } diff --git a/tests/cn-test-gen/src/bin_tree.pass.c b/tests/cn-test-gen/src/bin_tree.pass.c new file mode 100644 index 000000000..d36b12089 --- /dev/null +++ b/tests/cn-test-gen/src/bin_tree.pass.c @@ -0,0 +1,45 @@ +void* cn_malloc(unsigned long size); + +struct int_tree { + int key; + struct int_tree* left; + struct int_tree* right; +}; + +/*@ + datatype binary_tree { + Tree_Leaf {}, + Tree_Node { i32 key, datatype binary_tree left, datatype binary_tree right } + } + predicate (datatype binary_tree) IntTree(pointer p) { + if (is_null(p)) { + return Tree_Leaf {}; + } else { + take n = Owned(p); + take l = IntTree(n.left); + take r = IntTree(n.right); + return Tree_Node { key: n.key, left: l, right: r }; + } + } +@*/ + +struct int_tree* deepCopyRecursive(struct int_tree* p) + /*@ + requires + take T = IntTree(p); + ensures + take T_ = IntTree(p); + T == T_; + take T2 = IntTree(return); + T == T2; + @*/ +{ + if (p == 0) { + return 0; + } + struct int_tree* q = cn_malloc(sizeof(struct int_tree)); + q->key = p->key; + q->left = deepCopyRecursive(p->left); + q->right = deepCopyRecursive(p->right); + return q; +} diff --git a/tests/cn-test-gen/src/bst.fail.c b/tests/cn-test-gen/src/bst.fail.c new file mode 100644 index 000000000..c608670e9 --- /dev/null +++ b/tests/cn-test-gen/src/bst.fail.c @@ -0,0 +1,405 @@ +#include + +#define KEY int +#define VALUE long + +struct MapNode { + KEY key; + VALUE value; + struct MapNode *smaller; + struct MapNode *larger; +}; + +extern void* cn_malloc(size_t size); +extern void cn_free_sized(void *ptr, size_t size); + + +/*@ + +type_synonym KEY = i32 +type_synonym VALUE = i64 +type_synonym NodeData = { KEY key, VALUE value } + +function (KEY) defaultKey() { 0i32 } + +datatype ValueOption { + ValueNone {}, + ValueSome { VALUE value } +} + + +// ----------------------------------------------------------------------------- +// Intervals + +// Non-empty, closed intervals +type_synonym Interval = { KEY lower, KEY upper } + +function (Interval) defaultInterval() { + { lower: defaultKey(), upper: defaultKey() } +} + +datatype IntervalOption { + IntervalNone {}, + IntervalSome { Interval i } +} + +function (boolean) isIntervalSome(IntervalOption i) { + match i { + IntervalNone {} => { false } + IntervalSome { i:_ } => { true } + } +} + +function (Interval) fromIntervalOption(IntervalOption i) { + match i { + IntervalNone {} => { defaultInterval() } + IntervalSome { i:j } => { j } + } +} + + +function (IntervalOption) + joinInterval(IntervalOption optSmaller, KEY val, IntervalOption optLarger) { + match optSmaller { + IntervalNone {} => { + match optLarger { + IntervalNone {} => { + IntervalSome { i: { lower: val, upper: val } } + } + IntervalSome { i: larger } => { + if (val < larger.lower) { + IntervalSome { i: { lower: val, upper: larger.upper } } + } else { + IntervalNone {} + } + } + } + } + IntervalSome { i: smaller } => { + if (val > smaller.upper) { + match optLarger { + IntervalNone {} => { + IntervalSome { i: { lower: smaller.lower, upper: val } } + } + IntervalSome { i: larger } => { + if (val < larger.lower) { + IntervalSome { i: { lower: smaller.lower, upper: larger.upper } } + } else { + IntervalNone {} + } + } + } + } else { + IntervalNone {} + } + } + } +} + + + +// ----------------------------------------------------------------------------- + + + + +// A binary dearch tree +datatype BST { + Leaf {}, + Node { NodeData data, BST smaller, BST larger } +} + +function (boolean) hasRoot(KEY key, BST tree) { + match tree { + Leaf {} => { false } + Node { data: data, smaller: _, larger: _ } => { data.key == key } + } +} + +function [rec] (ValueOption) lookup(KEY key, BST tree) { + match tree { + Leaf {} => { ValueNone {} } + Node { data: data, smaller: smaller, larger: larger } => { + if (data.key == key) { + ValueSome { value: data.value } + } else { + if (data.key < key) { + lookup(key,larger) + } else { + lookup(key,smaller) + } + } + } + } +} + +function [rec] (boolean) member(KEY k, BST tree) { + match tree { + Leaf {} => { false } + Node { data: data, smaller: smaller, larger: larger } => { + data.key == k || + k < data.key && member(k,smaller) || + k > data.key && member(k,larger) + } + } +} + +function [rec] (BST) insert(KEY key, VALUE value, BST tree) { + match tree { + Leaf {} => { Node { data: { key: key, value: value }, + smaller: Leaf {}, larger: Leaf {} } } + Node { data: data, smaller: smaller, larger: larger } => { + if (data.key == key) { + Node { data: { key: key, value: value }, + smaller: smaller, larger: larger } + } else { + if (data.key < key) { + Node { data: data, + smaller: smaller, larger: insert(key,value,larger) } + } else { + Node { data: data, + smaller: insert(key,value,smaller), larger: larger } + } + } + } + } +} + +function [rec] (BST) setKey(KEY k, BST root, BST value) { + match root { + Leaf {} => { value } + Node { data: data, smaller: smaller, larger: larger } => { + if (k < data.key) { + Node { data: data, smaller: setKey(k, smaller, value), larger: larger } + } else { + Node { data: data, smaller: smaller, larger: setKey(k, larger, value) } + } + } + } +} + + + + +// ***************************************************************************** +// Consuming an entire tree +// ***************************************************************************** + + +// Semantic data stored at a node +function (NodeData) getNodeData(struct MapNode node) { + { key: node.key, value: node.value } +} + +type_synonym RangedBST = { BST tree, IntervalOption range } +type_synonym RangedNode = { + struct MapNode node, + BST smaller, + BST larger, + Interval range +} + +predicate RangedNode RangedNode(pointer root) { + take node = Owned(root); + take smaller = RangedBST(node.smaller); + take larger = RangedBST(node.larger); + let rangeOpt = joinInterval(smaller.range, node.key, larger.range); + assert (isIntervalSome(rangeOpt)); + return { node: node, smaller: smaller.tree, larger: larger.tree, + range: fromIntervalOption(rangeOpt) }; +} + +// A binary search tree, and the interval for all its keys. +predicate RangedBST RangedBST(pointer root) { + if (is_null(root)) { + return { tree: Leaf {}, range: IntervalNone{} }; + } else { + take node = RangedNode(root); + let data = getNodeData(node.node); + return { tree: Node { data: data, smaller: node.smaller, larger: node.larger }, + range: IntervalSome { i: node.range } }; + } +} + +// An arbitrary binary search tree. +predicate BST BST(pointer root) { + take result = RangedBST(root); + return result.tree; +} + + + + +// ***************************************************************************** +// Focusing on a node in the tree +// ***************************************************************************** + +type_synonym BSTNodeFocus = + { BST done, struct MapNode node, BST smaller, BST larger } + +datatype BSTFocus { + AtLeaf { BST tree }, + AtNode { BST done, struct MapNode node, BST smaller, BST larger } +} + +predicate BSTFocus BSTFocus(pointer root, pointer child) { + if (is_null(child)) { + take tree = BST(root); + return AtLeaf { tree: tree }; + } else { + take node = RangedNode(child); + take result = BSTNodeUpTo(root, child, node.node, node.range); + return AtNode { done: result.tree, node: node.node, + smaller: node.smaller, larger: node.larger }; + } +} + +// Consume parts of the tree starting at `p` until we get to `c`. +// We do not consume `c`. +// `child` is the node stored at `c`. +predicate RangedBST BSTNodeUpTo(pointer p, pointer c, struct MapNode child, Interval range) { + if (ptr_eq(p,c)) { + return { tree: Leaf {}, range: IntervalSome { i: range } }; + } else { + take parent = Owned(p); + take result = BSTNodeChildUpTo(c, child, range, parent); + return result; + } +} + +// Starting at a parent with data `data` and children `smaller` and `larger`, +// we go toward `c`, guided by its value, `target`. +predicate RangedBST + BSTNodeChildUpTo(pointer c, struct MapNode target, Interval range, struct MapNode parent) { + if (parent.key < target.key) { + take small = RangedBST(parent.smaller); + take large = BSTNodeUpTo(parent.larger, c, target, range); + let node = getNodeData(parent); + let optRange = joinInterval(small.range, node.key, large.range); + assert(isIntervalSome(optRange)); + return { tree: Node { data: node, smaller: small.tree, larger: large.tree }, + range: optRange }; + } else { + if (parent.key > target.key) { + take small = BSTNodeUpTo(parent.smaller, c, target, range); + take large = RangedBST(parent.larger); + let node = getNodeData(parent); + let optRange = joinInterval(small.range, node.key, large.range); + assert(isIntervalSome(optRange)); + return { tree: Node { data: node, smaller: small.tree, larger: large.tree }, + range: optRange }; + } else { + // We should never get here, but asserting `false` is not allowed + return { tree: Leaf {}, range: IntervalNone {} }; + }} +} + +function (BST) unfocus(BSTFocus focus) { + match focus { + AtLeaf { tree: tree } => { tree } + AtNode { done: tree, node: node, smaller: smaller, larger: larger } => { + let bst = Node { data: getNodeData(node), smaller: smaller, larger: larger }; + setKey(node.key, tree, bst) + } + } +} + +function (BST) focusDone(BSTFocus focus) { + match focus { + AtLeaf { tree: tree } => { tree } + AtNode { done: tree, node: _, smaller: _, larger: _ } => { tree } + } +} + + + +@*/ + + +/* Allocate a new singleton node */ +struct MapNode *newNode(KEY key, VALUE value) +/*@ +requires + true; +ensures + take node = Owned(return); + node.key == key; + node.value == value; + is_null(node.smaller); + is_null(node.larger); +@*/ +{ + struct MapNode *node = (struct MapNode*)cn_malloc(sizeof(struct MapNode)); + node->key = key; + node->value = value; + node->smaller = 0; + node->larger = 0; + return node; +} + + +struct MapNode *findParent(struct MapNode **node, KEY key) +/*@ +requires + take tree_ptr = Owned(node); + take tree = BST(tree_ptr); +ensures + take cur_ptr = Owned(node); + let not_found = is_null(cur_ptr); + not_found == !member(key, tree); + take focus = BSTFocus(tree_ptr, return); + unfocus(focus) == tree; + match focus { + AtLeaf { tree: _ } => { + not_found || ptr_eq(cur_ptr,tree_ptr) && hasRoot(key, tree) + } + AtNode { done: _, node: parent, smaller: _, larger: _ } => { + let tgt = if (key < parent.key) { parent.smaller } else { parent.larger }; + ptr_eq(cur_ptr,tgt) + } + }; +@*/ +{ + struct MapNode *parent = 0; + struct MapNode *cur = *node; + while (cur) + { + KEY k = cur->key; + if (k == key) { + *node = cur; + return parent; + } + parent = cur; + cur = k < key? cur->larger : cur->smaller; + } + *node = cur; + return parent; +} + +/* Insert an element into a map. Overwrites previous if already present. */ +void map_insert(struct MapNode **root, KEY key, VALUE value) +/*@ +requires + take root_ptr = Owned(root); + take tree = BST(root_ptr); +ensures + take new_root = Owned(root); + take new_tree = BST(new_root); + new_tree == insert(key, value, tree); +@*/ +{ + struct MapNode *search = *root; + struct MapNode *parent = findParent(&search, key); + + if (!parent) { + *root = newNode(key,value); + return; + } + + struct MapNode *new_node = newNode(key,value); + if (parent->key < key) { + parent->larger = new_node; + } else { + parent->smaller = new_node; + } +} diff --git a/tests/cn-test-gen/src/bst.pass.c b/tests/cn-test-gen/src/bst.pass.c index 1354ab10a..63fe55450 100644 --- a/tests/cn-test-gen/src/bst.pass.c +++ b/tests/cn-test-gen/src/bst.pass.c @@ -406,4 +406,4 @@ ensures } else { parent->smaller = new_node; } -} \ No newline at end of file +} From cee11e0ab012673a52f51d9049bfab42cf143037 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Sun, 10 Nov 2024 21:29:54 -0500 Subject: [PATCH 048/148] [CN-Test-Gen] Add more failing CI tests --- tests/cn-test-gen/src/sorted_list.cons.fail.c | 52 ++++++++++++ .../cn-test-gen/src/sorted_list.insert.fail.c | 82 +++++++++++++++++++ .../cn-test-gen/src/sorted_list.insert.pass.c | 82 +++++++++++++++++++ ...ted_list.pass.c => sorted_list.sum.pass.c} | 0 4 files changed, 216 insertions(+) create mode 100644 tests/cn-test-gen/src/sorted_list.cons.fail.c create mode 100644 tests/cn-test-gen/src/sorted_list.insert.fail.c create mode 100644 tests/cn-test-gen/src/sorted_list.insert.pass.c rename tests/cn-test-gen/src/{sorted_list.pass.c => sorted_list.sum.pass.c} (100%) diff --git a/tests/cn-test-gen/src/sorted_list.cons.fail.c b/tests/cn-test-gen/src/sorted_list.cons.fail.c new file mode 100644 index 000000000..dc3efb8b5 --- /dev/null +++ b/tests/cn-test-gen/src/sorted_list.cons.fail.c @@ -0,0 +1,52 @@ +// Sorted list + +struct List +{ + int value; + struct List* next; +}; + +/*@ +datatype IntList { + Nil {}, + Cons { i32 head, IntList tail } +} + +function (boolean) validCons(i32 head, IntList tail) { + match tail { + Nil {} => { true } + Cons { head: next, tail: _ } => { head <= next } + } +} + +predicate IntList ListSegment(pointer from, pointer to) { + if (ptr_eq(from,to)) { + return Nil {}; + } else { + take head = Owned(from); + take tail = ListSegment(head.next, to); + assert(validCons(head.value,tail)); + return Cons { head: head.value, tail: tail }; + } +} +@*/ + +void *cn_malloc(unsigned long size); + + +// This is invalid because we don't preserve the sorted invariant. +void cons(int x, struct List** xs) +/*@ + requires + take list_ptr = Owned(xs); + take list = ListSegment(list_ptr,NULL); + ensures + take new_list_ptr = Owned(xs); + take new_list = ListSegment(new_list_ptr,NULL); +@*/ +{ + struct List *node = (struct List*) cn_malloc(sizeof(struct List)); + node->value = x; + node->next = *xs; + *xs = node; +} diff --git a/tests/cn-test-gen/src/sorted_list.insert.fail.c b/tests/cn-test-gen/src/sorted_list.insert.fail.c new file mode 100644 index 000000000..8740aefac --- /dev/null +++ b/tests/cn-test-gen/src/sorted_list.insert.fail.c @@ -0,0 +1,82 @@ +// Sorted list + +struct List +{ + int value; + struct List* next; +}; + +/*@ +datatype IntList { + Nil {}, + Cons { i32 head, IntList tail } +} + +function (boolean) validCons(i32 head, IntList tail) { + match tail { + Nil {} => { true } + Cons { head: next, tail: _ } => { head <= next } + } +} + +function [rec] (IntList) insertList(boolean dups, i32 x, IntList xs) { + match xs { + Nil {} => { Cons { head: x, tail: Nil {} } } + Cons { head: head, tail: tail } => { + if (head < x) { + Cons { head: head, tail: insertList(dups, x,tail) } + } else { + if (!dups && head == x) { + xs + } else { + Cons { head: x, tail: xs } + } + } + } + } +} + +predicate IntList ListSegment(pointer from, pointer to) { + if (ptr_eq(from,to)) { + return Nil {}; + } else { + take head = Owned(from); + take tail = ListSegment(head.next, to); + assert(validCons(head.value,tail)); + return Cons { head: head.value, tail: tail }; + } +} +@*/ + +void *cn_malloc(unsigned long size); + +void insert(int x, struct List **xs) +/*@ + requires + take list_ptr = Owned(xs); + take list = ListSegment(list_ptr,NULL); + ensures + take new_list_ptr = Owned(xs); + take new_list = ListSegment(new_list_ptr,NULL); + new_list == insertList(false,x,list); +@*/ +{ + struct List *node = (struct List*) cn_malloc(sizeof(struct List)); + node->value = x; + + struct List* prev = 0; + struct List* cur = *xs; + while (cur && cur->value < x) { + prev = cur; + cur = cur->next; + } + + if (prev) { + prev->next = node; + node->next = cur; + } else { + node->next = *xs; + *xs = node; + } + +} diff --git a/tests/cn-test-gen/src/sorted_list.insert.pass.c b/tests/cn-test-gen/src/sorted_list.insert.pass.c new file mode 100644 index 000000000..69e3da2ed --- /dev/null +++ b/tests/cn-test-gen/src/sorted_list.insert.pass.c @@ -0,0 +1,82 @@ +// Sorted list + +struct List +{ + int value; + struct List* next; +}; + +/*@ +datatype IntList { + Nil {}, + Cons { i32 head, IntList tail } +} + +function (boolean) validCons(i32 head, IntList tail) { + match tail { + Nil {} => { true } + Cons { head: next, tail: _ } => { head <= next } + } +} + +function [rec] (IntList) insertList(boolean dups, i32 x, IntList xs) { + match xs { + Nil {} => { Cons { head: x, tail: Nil {} } } + Cons { head: head, tail: tail } => { + if (head < x) { + Cons { head: head, tail: insertList(dups, x,tail) } + } else { + if (!dups && head == x) { + xs + } else { + Cons { head: x, tail: xs } + } + } + } + } +} + +predicate IntList ListSegment(pointer from, pointer to) { + if (ptr_eq(from,to)) { + return Nil {}; + } else { + take head = Owned(from); + take tail = ListSegment(head.next, to); + assert(validCons(head.value,tail)); + return Cons { head: head.value, tail: tail }; + } +} +@*/ + +void *cn_malloc(unsigned long size); + +void insert(int x, struct List **xs) +/*@ + requires + take list_ptr = Owned(xs); + take list = ListSegment(list_ptr,NULL); + ensures + take new_list_ptr = Owned(xs); + take new_list = ListSegment(new_list_ptr,NULL); + new_list == insertList(true,x,list); +@*/ +{ + struct List *node = (struct List*) cn_malloc(sizeof(struct List)); + node->value = x; + + struct List* prev = 0; + struct List* cur = *xs; + while (cur && cur->value < x) { + prev = cur; + cur = cur->next; + } + + if (prev) { + prev->next = node; + node->next = cur; + } else { + node->next = *xs; + *xs = node; + } + +} diff --git a/tests/cn-test-gen/src/sorted_list.pass.c b/tests/cn-test-gen/src/sorted_list.sum.pass.c similarity index 100% rename from tests/cn-test-gen/src/sorted_list.pass.c rename to tests/cn-test-gen/src/sorted_list.sum.pass.c From 567038bdf533e709ea42b10cf387c53ad2d6f1cc Mon Sep 17 00:00:00 2001 From: Michal Podhradsky Date: Fri, 8 Nov 2024 15:27:47 -0800 Subject: [PATCH 049/148] Pin redhat image to 9.4 release --- Dockerfile.redhat | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile.redhat b/Dockerfile.redhat index 0c526a306..f7101cbb1 100644 --- a/Dockerfile.redhat +++ b/Dockerfile.redhat @@ -1,4 +1,4 @@ -FROM redhat/ubi9:latest +FROM redhat/ubi9:9.4 # Install basic dependencies RUN yum update -y && \ From 7a81691c81b2a4e028d311f98631a608b31b001c Mon Sep 17 00:00:00 2001 From: Michal Podhradsky Date: Fri, 8 Nov 2024 15:52:04 -0800 Subject: [PATCH 050/148] Update documentation for using docker, run a CI test for the docker images, and add a newer z3 package into the Ubuntu docker image (installed via opam) --- .github/workflows/docker.yml | 13 +++++++++++++ Dockerfile.ubuntu | 1 + README.md | 16 ++++++++++++++-- backend/cn/README.md | 2 +- 4 files changed, 29 insertions(+), 3 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index f872e0a3c..d706c6f08 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -82,3 +82,16 @@ jobs: attests: type=sbom provenance: mode=max github-token: ${{ secrets.GITHUB_TOKEN }} + + test-docker-images: + runs-on: ubuntu-latest + strategy: + matrix: + tag: [release, release-redhat] + steps: + - uses: actions/checkout@v4 + + - name: Run CN CI tests + run: | + docker pull ${{env.CERBERUS_IMAGE_ID}}:${{ matrix.tag }} + docker run -v $PWD:/work ${{env.CERBERUS_IMAGE_ID}}:${{ matrix.tag }} tests/run-cn.sh diff --git a/Dockerfile.ubuntu b/Dockerfile.ubuntu index 4fe361313..26657ef57 100644 --- a/Dockerfile.ubuntu +++ b/Dockerfile.ubuntu @@ -11,6 +11,7 @@ RUN opam init --disable-sandboxing ADD . /opt/cerberus WORKDIR /opt/cerberus RUN opam install --deps-only ./cerberus-lib.opam ./cn.opam +RUN opam install z3 RUN eval `opam env` \ && make install_cn diff --git a/README.md b/README.md index ab6ccfde2..28c2991a5 100644 --- a/README.md +++ b/README.md @@ -183,10 +183,22 @@ See https://github.com/rems-project/cerberus/blob/master/backend/cn/README.md Docker image ------------ +A pre-build docker image with `cerberus` and `cn` can be downloaded with: + +* For the Ubuntu 22.04 based image (recommended): + ```bash + $ docker pull ghcr.io/rems-project/cerberus/cn:release + ``` +* For Redhat Ubi9 based image: + ```bash + $ docker pull ghcr.io/rems-project/cerberus/cn:release-redhat + ``` + +For a local build, run: ```bash -$ make -f Makefile_docker +$ docker build -t cn:release -f Dockerfile.ubuntu . ``` -creates a Docker image than can be used for example with: +which creates a Docker image than can be used for example with: ```bash $ docker run --volume `PWD`:/data/ cerberus:0.1 tests/tcc/00_assignment.c --pp=core ``` diff --git a/backend/cn/README.md b/backend/cn/README.md index d01710fa3..b89883ffe 100644 --- a/backend/cn/README.md +++ b/backend/cn/README.md @@ -18,7 +18,7 @@ and their dependencies. Note: there is a [known bug with Z3 version 4.8.13](https://github.com/rems-project/cerberus/issues/663) (the default on Ubuntu 22.04) so you may wish to install Z3 via opam later for a more - up-to-date version. CVC5 + up-to-date version. Z3 that is provided in the docker images is sufficiently up-to-date. 2. Install the opam package manager for OCaml: https://ocaml.org/docs/installing-ocaml#install-opam. From 3d8662d625a175c5f79398f5d4544fa5c6c6e446 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Thu, 7 Nov 2024 16:01:26 +0000 Subject: [PATCH 051/148] some tidying up of the mergesort example --- tests/cn/mergesort.c | 178 ++++++++++++++++++++----------------------- 1 file changed, 83 insertions(+), 95 deletions(-) diff --git a/tests/cn/mergesort.c b/tests/cn/mergesort.c index 3c7a2e02c..594bfe7d4 100644 --- a/tests/cn/mergesort.c +++ b/tests/cn/mergesort.c @@ -1,172 +1,160 @@ -struct int_list { - int head; - struct int_list* tail; +struct node { + int value; + struct node* next; }; /*@ -datatype seq { - Seq_Nil {}, - Seq_Cons {i32 head, datatype seq tail} +datatype list { + Nil {}, + Cons {i32 head, list tail} } -predicate (datatype seq) IntList(pointer p) { +predicate (list) List(pointer p) { if (is_null(p)) { - return Seq_Nil{}; + return Nil {}; } else { - take H = Owned(p); - assert (is_null(H.tail) || !addr_eq(H.tail, NULL)); - take tl = IntList(H.tail); - return (Seq_Cons { head: H.head, tail: tl }); + take node = Owned(p); + take tl = List(node.next); + return (Cons { head: node.value, tail: tl }); } } -function [rec] ({datatype seq fst, datatype seq snd}) cn_split(datatype seq xs) -{ +function [rec] ({list fst, list snd}) cn_split(list xs) { match xs { - Seq_Nil {} => { - {fst: Seq_Nil{}, snd: Seq_Nil{}} + Nil {} => { + {fst: Nil {}, snd: Nil {}} } - Seq_Cons {head: h1, tail: Seq_Nil{}} => { - {fst: Seq_Nil{}, snd: xs} + Cons {head: h1, tail: Nil {}} => { + {fst: Nil {}, snd: xs} } - Seq_Cons {head: h1, tail: Seq_Cons {head : h2, tail : tl2 }} => { + Cons {head: h1, tail: Cons {head : h2, tail : tl2 }} => { let P = cn_split(tl2); - {fst: Seq_Cons { head: h1, tail: P.fst}, - snd: Seq_Cons { head: h2, tail: P.snd}} + {fst: Cons { head: h1, tail: P.fst}, + snd: Cons { head: h2, tail: P.snd}} } } } -function [rec] (datatype seq) cn_merge(datatype seq xs, datatype seq ys) { +function [rec] (list) cn_merge(list xs, list ys) { match xs { - Seq_Nil {} => { ys } - Seq_Cons {head: x, tail: xs1} => { + Nil {} => { + ys + } + Cons {head: x, tail: xs1} => { match ys { - Seq_Nil {} => { xs } - Seq_Cons{ head: y, tail: ys1} => { + Nil {} => { + xs + } + Cons { head: y, tail: ys1} => { let tail = cn_merge(xs1, ys1); (x < y) ? - (Seq_Cons{ head: x, tail: Seq_Cons {head: y, tail: tail}}) - : (Seq_Cons{ head: y, tail: Seq_Cons {head: x, tail: tail}}) + (Cons { head: x, tail: Cons {head: y, tail: tail}}) + : (Cons { head: y, tail: Cons {head: x, tail: tail}}) } } } } } -function [rec] (datatype seq) cn_mergesort(datatype seq xs) { +function [rec] (list) cn_mergesort(list xs) { match xs { - Seq_Nil{} => { xs } - Seq_Cons{head: x, tail: Seq_Nil{}} => { xs } - Seq_Cons{head: x, tail: Seq_Cons{head: y, tail: zs}} => { - let P = cn_split(xs); - let L1 = cn_mergesort(P.fst); - let L2 = cn_mergesort(P.snd); - cn_merge(L1, L2) - } + Nil {} => { + xs + } + Cons {head: x, tail: Nil {}} => { + xs + } + Cons {head: x, tail: Cons {head: y, tail: zs}} => { + let P = cn_split(xs); + let L1 = cn_mergesort(P.fst); + let L2 = cn_mergesort(P.snd); + cn_merge(L1, L2) } + } } @*/ -struct int_list_pair { - struct int_list* fst; - struct int_list* snd; +struct node_pair { + struct node* fst; + struct node* snd; }; -struct int_list_pair split(struct int_list *xs) -/*@ requires is_null(xs) || !addr_eq(xs, NULL); @*/ -/*@ requires take Xs = IntList(xs); @*/ -/*@ ensures take Ys = IntList(return.fst); @*/ -/*@ ensures take Zs = IntList(return.snd); @*/ -/*@ ensures is_null(return.fst) || !addr_eq(return.fst, NULL); @*/ -/*@ ensures is_null(return.snd) || !addr_eq(return.snd, NULL); @*/ +struct node_pair split(struct node *xs) +/*@ requires take Xs = List(xs); @*/ +/*@ ensures take Ys = List(return.fst); @*/ +/*@ ensures take Zs = List(return.snd); @*/ /*@ ensures {fst: Ys, snd: Zs} == cn_split(Xs); @*/ { + /*@ unfold cn_split(Xs); @*/ if (xs == 0) { - /*@ unfold cn_split(Xs); @*/ - struct int_list_pair r = {.fst = 0, .snd = 0}; + struct node_pair r = {.fst = 0, .snd = 0}; return r; } else { - struct int_list *cdr = xs -> tail; + struct node *cdr = xs->next; if (cdr == 0) { - /*@ unfold cn_split(Xs); @*/ - struct int_list_pair r = {.fst = 0, .snd = xs}; + struct node_pair r = {.fst = 0, .snd = xs}; return r; } else { - /*@ unfold cn_split(Xs); @*/ - struct int_list_pair p = split(cdr->tail); - xs->tail = p.fst; - cdr->tail = p.snd; - struct int_list_pair r = {.fst = xs, .snd = cdr}; + struct node_pair p = split(cdr->next); + xs->next = p.fst; + cdr->next = p.snd; + struct node_pair r = {.fst = xs, .snd = cdr}; return r; } } } -struct int_list* merge(struct int_list *xs, struct int_list *ys) -/*@ requires is_null(xs) || !addr_eq(xs, NULL); @*/ -/*@ requires is_null(ys) || !addr_eq(ys, NULL); @*/ -/*@ requires take Xs = IntList(xs); @*/ -/*@ requires take Ys = IntList(ys); @*/ -/*@ ensures is_null(return) || !addr_eq(return, NULL); @*/ -/*@ ensures take Zs = IntList(return); @*/ +struct node* merge(struct node *xs, struct node *ys) +/*@ requires take Xs = List(xs); @*/ +/*@ requires take Ys = List(ys); @*/ +/*@ ensures take Zs = List(return); @*/ /*@ ensures Zs == cn_merge(Xs, Ys); @*/ { + /*@ unfold cn_merge(Xs, Ys); @*/ if (xs == 0) { - /*@ unfold cn_merge(Xs, Ys); @*/ return ys; } else { - /*@ unfold cn_merge(Xs, Ys); @*/ if (ys == 0) { - /*@ unfold cn_merge(Xs, Ys); @*/ return xs; } else { - /*@ unfold cn_merge(Xs, Ys); @*/ - struct int_list *zs = merge(xs->tail, ys->tail); - if (xs->head < ys->head) { - xs->tail = ys; - ys->tail = zs; + struct node *zs = merge(xs->next, ys->next); + if (xs->value < ys->value) { + xs->next = ys; + ys->next = zs; return xs; } else { - ys->tail = xs; - xs->tail = zs; + ys->next = xs; + xs->next = zs; return ys; } } } } -struct int_list* naive_mergesort(struct int_list *xs) -/*@ requires is_null(xs) || !addr_eq(xs, NULL); @*/ -/*@ requires take Xs = IntList(xs); @*/ -/*@ ensures take Ys = IntList(return); @*/ -/*@ ensures is_null(return) || !addr_eq(return, NULL); @*/ +struct node* naive_mergesort(struct node *xs) +/*@ requires take Xs = List(xs); @*/ +/*@ ensures take Ys = List(return); @*/ /*@ ensures Ys == cn_mergesort(Xs); @*/ { + /*@ unfold cn_mergesort(Xs); @*/ if (xs == 0) { - /*@ unfold cn_mergesort(Xs); @*/ + return xs; + } else if (xs->next == 0) { return xs; } else { - struct int_list *tail = xs->tail; - if (tail == 0) { - /*@ unfold cn_mergesort(Xs); @*/ - return xs; - } else { - /*@ unfold cn_mergesort(Xs); @*/ - struct int_list_pair p = split(xs); - p.fst = naive_mergesort(p.fst); - p.snd = naive_mergesort(p.snd); - return merge(p.fst, p.snd); - } + struct node_pair p = split(xs); + p.fst = naive_mergesort(p.fst); + p.snd = naive_mergesort(p.snd); + return merge(p.fst, p.snd); } } int main(void) /*@ trusted; @*/ { - struct int_list i3 = {.head = 3, .tail = 0}; - struct int_list i2 = {.head = 4, .tail = &i3}; - struct int_list i1 = {.head = 2, .tail = &i2}; + struct node i3 = {.value = 3, .next = 0}; + struct node i2 = {.value = 4, .next = &i3}; + struct node i1 = {.value = 2, .next = &i2}; - struct int_list *sorted_i1 = naive_mergesort(&i1); + struct node *sorted_i1 = naive_mergesort(&i1); } From b3338dd568b615d81b62105711bb1848e8c8e222 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 8 Nov 2024 11:56:37 +0000 Subject: [PATCH 052/148] correct merge sort, now with is_sorted proof --- tests/cn/mergesort.c | 154 +++++++++++++++++++++++++++++++++---------- 1 file changed, 119 insertions(+), 35 deletions(-) diff --git a/tests/cn/mergesort.c b/tests/cn/mergesort.c index 594bfe7d4..716c3d2bb 100644 --- a/tests/cn/mergesort.c +++ b/tests/cn/mergesort.c @@ -1,6 +1,6 @@ struct node { int value; - struct node* next; + struct node *next; }; /*@ @@ -25,7 +25,7 @@ function [rec] ({list fst, list snd}) cn_split(list xs) { {fst: Nil {}, snd: Nil {}} } Cons {head: h1, tail: Nil {}} => { - {fst: Nil {}, snd: xs} + {fst: xs, snd: Nil {}} } Cons {head: h1, tail: Cons {head : h2, tail : tl2 }} => { let P = cn_split(tl2); @@ -37,22 +37,23 @@ function [rec] ({list fst, list snd}) cn_split(list xs) { function [rec] (list) cn_merge(list xs, list ys) { match xs { - Nil {} => { - ys - } - Cons {head: x, tail: xs1} => { - match ys { - Nil {} => { - xs + Nil {} => { + ys + } + Cons {head: x, tail: xs_} => { + match ys { + Nil {} => { + xs + } + Cons {head: y, tail: ys_} => { + if (x <= y) { + Cons {head: x, tail: cn_merge(xs_, ys)} + } else { + Cons {head: y, tail: cn_merge(xs, ys_)} } - Cons { head: y, tail: ys1} => { - let tail = cn_merge(xs1, ys1); - (x < y) ? - (Cons { head: x, tail: Cons {head: y, tail: tail}}) - : (Cons { head: y, tail: Cons {head: x, tail: tail}}) - } - } + } } + } } } @@ -72,11 +73,44 @@ function [rec] (list) cn_mergesort(list xs) { } } } + +function (boolean) smaller (i32 head, list xs) { + match xs { + Nil {} => { + true + } + Cons {head : x, tail : _} => { + head <= x + } + } +} + +function [rec] (boolean) is_sorted(list xs) { + match xs { + Nil {} => { + true + } + Cons {head: head, tail: tail} => { + smaller (head, tail) && is_sorted(tail) + } + } +} + +function (list) tl (list xs) { + match xs { + Nil {} => { + Nil {} + } + Cons {head : _, tail : tail} => { + tail + } + } +} @*/ struct node_pair { - struct node* fst; - struct node* snd; + struct node *fst; + struct node *snd; }; struct node_pair split(struct node *xs) @@ -92,7 +126,7 @@ struct node_pair split(struct node *xs) } else { struct node *cdr = xs->next; if (cdr == 0) { - struct node_pair r = {.fst = 0, .snd = xs}; + struct node_pair r = {.fst = xs, .snd = 0}; return r; } else { struct node_pair p = split(cdr->next); @@ -104,7 +138,7 @@ struct node_pair split(struct node *xs) } } -struct node* merge(struct node *xs, struct node *ys) +struct node *merge(struct node *xs, struct node *ys) /*@ requires take Xs = List(xs); @*/ /*@ requires take Ys = List(ys); @*/ /*@ ensures take Zs = List(return); @*/ @@ -113,25 +147,18 @@ struct node* merge(struct node *xs, struct node *ys) /*@ unfold cn_merge(Xs, Ys); @*/ if (xs == 0) { return ys; + } else if (ys == 0) { + return xs; + } else if (xs->value <= ys->value) { + xs->next = merge(xs->next, ys); + return xs; } else { - if (ys == 0) { - return xs; - } else { - struct node *zs = merge(xs->next, ys->next); - if (xs->value < ys->value) { - xs->next = ys; - ys->next = zs; - return xs; - } else { - ys->next = xs; - xs->next = zs; - return ys; - } - } + ys->next = merge(xs, ys->next); + return ys; } } -struct node* naive_mergesort(struct node *xs) +struct node *naive_mergesort(struct node *xs) /*@ requires take Xs = List(xs); @*/ /*@ ensures take Ys = List(return); @*/ /*@ ensures Ys == cn_mergesort(Xs); @*/ @@ -149,6 +176,9 @@ struct node* naive_mergesort(struct node *xs) } } + + + int main(void) /*@ trusted; @*/ { @@ -158,3 +188,57 @@ int main(void) struct node *sorted_i1 = naive_mergesort(&i1); } + + + + + +void prove_merge_sorted(struct node *p, struct node *q) +/*@ requires take xs_in = List(p); + take ys_in = List(q); + is_sorted(xs_in); + is_sorted(ys_in); + let merged = cn_merge(xs_in, ys_in); + ensures take xs_out = List(p); + take ys_out = List(q); + xs_out == xs_in && ys_out == ys_in; + is_sorted(merged); +@*/ +{ + /* Unfold the definition of `merged`. */ + /*@ unfold cn_merge(xs_in, ys_in); @*/ + + /* If either list is empty, cn_merge just picks the other, which is + sorted by assumption, so nothing left to do. */ + if (p == 0 || q == 0) { + return; + } + /* For non-empty lists, cn_merge picks the smaller head and merges + the rest. */ + else { + /* If `xs_in` has the smaller head, it merges `tl(xs_in)` with + `ys_in`. */ + if (p->value <= q->value) { + /* By induction hypothesis (IH) `cn_merge(tl(xs_in), ys_in))` is + sorted. To "apply" IH, expand the definition of + `is_sorted(xs_in)` to prove `is_sorted(tl(xs_in))`. */ + /*@ unfold is_sorted(xs_in); @*/ + prove_merge_sorted(p->next, q); + /* By definition of `cn_merge(tl(xs_in), ys_in)`, that merged + list starts with the minimum of either head, ... */ + /*@ unfold cn_merge(tl(xs_in), ys_in); @*/ + /* ... so that list with `hd(xs_in)` cons'ed on is also + sorted. @*/ + /*@ unfold is_sorted(merged); @*/ + return; + } + else { + /* This is symmetric to the proof above. */ + /*@ unfold is_sorted(ys_in); @*/ + prove_merge_sorted(p, q->next); + /*@ unfold cn_merge(xs_in, tl(ys_in)); @*/ + /*@ unfold is_sorted(merged); @*/ + return; + } + } +} From 7e05dbe042549f60794a67296eb524ddd11ce1f0 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 8 Nov 2024 12:11:48 +0000 Subject: [PATCH 053/148] more cleanup --- tests/cn/mergesort.c | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/tests/cn/mergesort.c b/tests/cn/mergesort.c index 716c3d2bb..3a5df62c1 100644 --- a/tests/cn/mergesort.c +++ b/tests/cn/mergesort.c @@ -114,10 +114,10 @@ struct node_pair { }; struct node_pair split(struct node *xs) -/*@ requires take Xs = List(xs); @*/ -/*@ ensures take Ys = List(return.fst); @*/ -/*@ ensures take Zs = List(return.snd); @*/ -/*@ ensures {fst: Ys, snd: Zs} == cn_split(Xs); @*/ +/*@ requires take Xs = List(xs); + ensures take Ys = List(return.fst); + ensures take Zs = List(return.snd); + ensures {fst: Ys, snd: Zs} == cn_split(Xs); @*/ { /*@ unfold cn_split(Xs); @*/ if (xs == 0) { @@ -139,10 +139,10 @@ struct node_pair split(struct node *xs) } struct node *merge(struct node *xs, struct node *ys) -/*@ requires take Xs = List(xs); @*/ -/*@ requires take Ys = List(ys); @*/ -/*@ ensures take Zs = List(return); @*/ -/*@ ensures Zs == cn_merge(Xs, Ys); @*/ +/*@ requires take Xs = List(xs); + requires take Ys = List(ys); + ensures take Zs = List(return); + ensures Zs == cn_merge(Xs, Ys); @*/ { /*@ unfold cn_merge(Xs, Ys); @*/ if (xs == 0) { @@ -159,9 +159,9 @@ struct node *merge(struct node *xs, struct node *ys) } struct node *naive_mergesort(struct node *xs) -/*@ requires take Xs = List(xs); @*/ -/*@ ensures take Ys = List(return); @*/ -/*@ ensures Ys == cn_mergesort(Xs); @*/ +/*@ requires take Xs = List(xs); + ensures take Ys = List(return); + ensures Ys == cn_mergesort(Xs); @*/ { /*@ unfold cn_mergesort(Xs); @*/ if (xs == 0) { From baa187fcfb665a449dcae1318fbe70f19c7a273c Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 8 Nov 2024 15:58:54 +0000 Subject: [PATCH 054/148] check in mergesort_alt, on the way to a more C-like version --- tests/cn/mergesort.c | 2 + tests/cn/mergesort_alt.c | 262 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 264 insertions(+) create mode 100644 tests/cn/mergesort_alt.c diff --git a/tests/cn/mergesort.c b/tests/cn/mergesort.c index 3a5df62c1..07341a1b5 100644 --- a/tests/cn/mergesort.c +++ b/tests/cn/mergesort.c @@ -18,7 +18,9 @@ predicate (list) List(pointer p) { return (Cons { head: node.value, tail: tl }); } } +@*/ +/*@ function [rec] ({list fst, list snd}) cn_split(list xs) { match xs { Nil {} => { diff --git a/tests/cn/mergesort_alt.c b/tests/cn/mergesort_alt.c new file mode 100644 index 000000000..af2d81537 --- /dev/null +++ b/tests/cn/mergesort_alt.c @@ -0,0 +1,262 @@ +struct node { + int value; + struct node *next; +}; + +typedef struct node * ilist; + +/*@ +datatype list { + Nil {}, + Cons {i32 head, list tail} +} + +predicate (list) List(pointer p) { + if (is_null(p)) { + return Nil {}; + } else { + take node = Owned(p); + take tl = List(node.next); + return (Cons { head: node.value, tail: tl }); + } +} + +predicate (list) ListP(pointer p) { + take l = Owned(p); + take xs = List(l); + return xs; +} +@*/ + +/*@ +function [rec] ({list fst, list snd}) cn_split(list xs) { + match xs { + Nil {} => { + {fst: Nil {}, snd: Nil {}} + } + Cons {head: h1, tail: Nil {}} => { + {fst: xs, snd: Nil {}} + } + Cons {head: h1, tail: Cons {head : h2, tail : tl2 }} => { + let P = cn_split(tl2); + {fst: Cons { head: h1, tail: P.fst}, + snd: Cons { head: h2, tail: P.snd}} + } + } +} + +function [rec] (list) cn_merge(list xs, list ys) { + match xs { + Nil {} => { + ys + } + Cons {head: x, tail: xs_} => { + match ys { + Nil {} => { + xs + } + Cons {head: y, tail: ys_} => { + if (x <= y) { + Cons {head: x, tail: cn_merge(xs_, ys)} + } else { + Cons {head: y, tail: cn_merge(xs, ys_)} + } + } + } + } + } +} + +function [rec] (list) cn_mergesort(list xs) { + match xs { + Nil {} => { + xs + } + Cons {head: x, tail: Nil {}} => { + xs + } + Cons {head: x, tail: Cons {head: y, tail: zs}} => { + let P = cn_split(xs); + let L1 = cn_mergesort(P.fst); + let L2 = cn_mergesort(P.snd); + cn_merge(L1, L2) + } + } +} + +function (boolean) smaller (i32 head, list xs) { + match xs { + Nil {} => { + true + } + Cons {head : x, tail : _} => { + head <= x + } + } +} + +function [rec] (boolean) is_sorted(list xs) { + match xs { + Nil {} => { + true + } + Cons {head: head, tail: tail} => { + smaller (head, tail) && is_sorted(tail) + } + } +} + +function (list) tl (list xs) { + match xs { + Nil {} => { + Nil {} + } + Cons {head : _, tail : tail} => { + tail + } + } +} +@*/ + +ilist split(ilist xs) +/*@ requires take Xs = List(xs); + ensures take Ys = List(xs); + ensures take Zs = List(return); + ensures {fst: Ys, snd: Zs} == cn_split(Xs); +@*/ +{ + /*@ unfold cn_split(Xs); @*/ + if (xs == 0 || xs->next == 0) { + return 0; + } else { + struct node *cdr = xs->next; + ilist ys = split(cdr->next); + xs->next = cdr->next; + cdr->next = ys; + return cdr; + } +} + + +void prove_merge_sorted(struct node *p, struct node *q) +/*@ requires take xs_in = List(p); + take ys_in = List(q); + is_sorted(xs_in); + is_sorted(ys_in); + let merged = cn_merge(xs_in, ys_in); + ensures take xs_out = List(p); + take ys_out = List(q); + xs_out == xs_in && ys_out == ys_in; + is_sorted(merged); +@*/ +{ + /* Unfold the definition of `merged`. */ + /*@ unfold cn_merge(xs_in, ys_in); @*/ + + /* If either list is empty, cn_merge just picks the other, which is + sorted by assumption, so nothing left to do. */ + if (p == 0 || q == 0) { + return; + } + /* For non-empty lists, cn_merge picks the smaller head and merges + the rest. */ + else { + /* If `xs_in` has the smaller head, it merges `tl(xs_in)` with + `ys_in`. */ + if (p->value <= q->value) { + /* By induction hypothesis (IH) `cn_merge(tl(xs_in), ys_in))` is + sorted. To "apply" IH, expand the definition of + `is_sorted(xs_in)` to prove `is_sorted(tl(xs_in))`. */ + /*@ unfold is_sorted(xs_in); @*/ + prove_merge_sorted(p->next, q); + /* By definition of `cn_merge(tl(xs_in), ys_in)`, that merged + list starts with the minimum of either head, ... */ + /*@ unfold cn_merge(tl(xs_in), ys_in); @*/ + /* ... so that list with `hd(xs_in)` cons'ed on is also + sorted. @*/ + /*@ unfold is_sorted(merged); @*/ + return; + } + else { + /* This is symmetric to the proof above. */ + /*@ unfold is_sorted(ys_in); @*/ + prove_merge_sorted(p, q->next); + /*@ unfold cn_merge(xs_in, tl(ys_in)); @*/ + /*@ unfold is_sorted(merged); @*/ + return; + } + } +} + + +struct node *merge(struct node *xs, struct node *ys) +/*@ requires take Xs = List(xs); + requires take Ys = List(ys); + ensures take Zs = List(return); + ensures Zs == cn_merge(Xs, Ys); @*/ +{ + /*@ unfold cn_merge(Xs, Ys); @*/ + if (xs == 0) { + return ys; + } else if (ys == 0) { + return xs; + } else if (xs->value <= ys->value) { + xs->next = merge(xs->next, ys); + return xs; + } else { + ys->next = merge(xs, ys->next); + return ys; + } +} + +void naive_mergesort(ilist *p) +/*@ requires take xs_in = ListP(p); + let sorted = cn_mergesort(xs_in); + ensures take xs_out = ListP(p); + xs_out == sorted; + is_sorted(xs_out); +@*/ +{ + /*@ unfold cn_mergesort(xs_in); @*/ + /*@ unfold is_sorted(sorted); @*/ + /*@ unfold is_sorted(tl(sorted)); @*/ + ilist xs = *p; + if (xs != 0 && xs->next != 0) { + ilist ys = split(xs); + naive_mergesort(&xs); + naive_mergesort(&ys); + /*CN*/ prove_merge_sorted(xs, ys); + *p = merge(xs, ys); + return; + } +} + + + + +int main(void) +/*@ trusted; @*/ +{ + ilist xs; + struct node n1; + struct node n2; + struct node n3; + + n1.value = 1; + n2.value = 4; + n3.value = 3; + + xs = &n1; + n1.next = &n2; + n2.next = &n3; + n3.next = 0; + + naive_mergesort(&xs); +} + + + + + + + From e3fa46424890e5d6b79dff6d8b5aec995b4072ac Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 12 Nov 2024 02:44:23 -0500 Subject: [PATCH 055/148] [CN-Test-Gen] Coverage support via `lcov` --- backend/cn/bin/main.ml | 10 +- backend/cn/lib/testGeneration/specTests.ml | 119 +++++++++++++----- .../cn/lib/testGeneration/testGenConfig.ml | 8 +- .../cn/lib/testGeneration/testGenConfig.mli | 5 +- 4 files changed, 107 insertions(+), 35 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 60fb8a3c1..5b7cf3094 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -446,6 +446,7 @@ let run_tests exit_fast max_stack_depth max_generator_size + coverage = (* flags *) Cerb_debug.debug_level := debug_level; @@ -509,7 +510,8 @@ let run_tests until_timeout; exit_fast; max_stack_depth; - max_generator_size + max_generator_size; + coverage } in TestGeneration.run @@ -969,6 +971,11 @@ module Testing_flags = struct value & opt (some int) TestGeneration.default_cfg.max_generator_size & info [ "max-generator-size" ] ~doc) + + + let test_coverage = + let doc = "Record coverage of tests" in + Arg.(value & flag & info [ "coverage" ] ~doc) end let testing_cmd = @@ -1001,6 +1008,7 @@ let testing_cmd = $ Testing_flags.test_exit_fast $ Testing_flags.test_max_stack_depth $ Testing_flags.test_max_generator_size + $ Testing_flags.test_coverage in let doc = "Generates RapidCheck tests for all functions in [FILE] with CN specifications.\n\ diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 78127e685..c4a16bbef 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -260,6 +260,19 @@ let compile_assumes (None, { A.empty_sigma with declarations; function_definitions }) +let should_be_unit_test + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (inst : Core_to_mucore.instrumentation) + = + let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in + match decl with + | Decl_function (_, _, args, _, _, _) -> + List.is_empty args + && SymSet.is_empty + (LAT.free_vars (fun _ -> SymSet.empty) (AT.get_lat (Option.get inst.internal))) + | Decl_object _ -> failwith __LOC__ + + let compile_tests ~(without_ownership_checking : bool) (filename_base : string) @@ -267,20 +280,7 @@ let compile_tests (prog5 : unit Mucore.file) (insts : Core_to_mucore.instrumentation list) = - let unit_tests, random_tests = - List.partition - (fun (inst : Core_to_mucore.instrumentation) -> - let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in - match decl with - | Decl_function (_, _, args, _, _, _) -> - List.is_empty args - && SymSet.is_empty - (LAT.free_vars - (fun _ -> SymSet.empty) - (AT.get_lat (Option.get inst.internal))) - | Decl_object _ -> failwith __LOC__) - insts - in + let unit_tests, random_tests = List.partition (should_be_unit_test sigma) insts in let unit_tests_doc = compile_unit_tests unit_tests in let random_tests_doc = compile_random_tests sigma prog5 random_tests in let open Pp in @@ -366,7 +366,7 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = ^^ hardline) ^^ twice hardline ^^ string "TEST_DIR=" - ^^ string output_dir + ^^ string (Filename.dirname (Filename.concat output_dir "junk")) ^^ hardline ^^ twice hardline ^^ string "# Compile" @@ -381,7 +381,8 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = "\"-I${RUNTIME_PREFIX}/include/\""; "-o"; "\"${TEST_DIR}/" ^ Filename.chop_extension test_file ^ ".o\""; - "\"${TEST_DIR}/" ^ test_file ^ "\";"; + "\"${TEST_DIR}/" ^ test_file ^ "\""; + (if Config.is_coverage () then "--coverage;" else ";"); "then" ] ^^ nest 4 (hardline ^^ string "echo \"Compiled C files.\"") @@ -405,9 +406,11 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = "cc"; "-g"; "\"-I${RUNTIME_PREFIX}/include\""; - "-o \"${TEST_DIR}/tests.out\""; + "-o"; + "\"${TEST_DIR}/tests.out\""; "${TEST_DIR}/" ^ Filename.chop_extension test_file ^ ".o"; - "\"${RUNTIME_PREFIX}/libcn.a\";"; + "\"${RUNTIME_PREFIX}/libcn.a\""; + (if Config.is_coverage () then "--coverage;" else ";"); "then" ] ^^ nest 4 (hardline ^^ string "echo \"Linked C .o files.\"") @@ -429,7 +432,7 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = separate_map space string - ([ "${TEST_DIR}/tests.out" ] + ([ "\"${TEST_DIR}/tests.out\"" ] @ (Config.has_null_in_every () |> Option.map (fun null_in_every -> [ "--null-in-every"; string_of_int null_in_every ]) @@ -465,19 +468,68 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = |> Option.to_list |> List.flatten)) in - string "if" - ^^ space - ^^ cmd + cmd ^^ semi - ^^ space - ^^ string "then" - ^^ nest 4 (hardline ^^ string "exit 0") - ^^ hardline - ^^ string "else" - ^^ nest 4 (hardline ^^ string "exit 1") - ^^ hardline - ^^ string "fi" ^^ hardline + ^^ + if Config.is_coverage () then + string "# Coverage" + ^^ hardline + ^^ string "test_exit_code=$? # Save tests exit code for later" + ^^ twice hardline + ^^ string "pushd \"${TEST_DIR}\"" + ^^ twice hardline + ^^ string ("if gcov \"" ^ test_file ^ "\"; then") + ^^ nest 4 (hardline ^^ string "echo \"Recorded coverage via gcov.\"") + ^^ hardline + ^^ string "else" + ^^ nest + 4 + (hardline + ^^ string "printf \"Failed to record coverage.\"" + ^^ hardline + ^^ string "exit 1") + ^^ hardline + ^^ string "fi" + ^^ twice hardline + ^^ string "if lcov --capture --directory . --output-file coverage.info; then" + ^^ nest 4 (hardline ^^ string "echo \"Collected coverage via lcov.\"") + ^^ hardline + ^^ string "else" + ^^ nest + 4 + (hardline + ^^ string "printf \"Failed to collect coverage.\"" + ^^ hardline + ^^ string "exit 1") + ^^ hardline + ^^ string "fi" + ^^ twice hardline + ^^ separate_map + space + string + [ "if"; "genhtml"; "--output-directory"; "html"; "\"coverage.info\";"; "then" ] + ^^ nest + 4 + (hardline + ^^ string "echo \"Generated HTML report at \\\"${TEST_DIR}/html/\\\".\"") + ^^ hardline + ^^ string "else" + ^^ nest + 4 + (hardline + ^^ string "printf \"Failed to generate HTML report.\"" + ^^ hardline + ^^ string "exit 1") + ^^ hardline + ^^ string "fi" + ^^ twice hardline + ^^ string "popd" + ^^ twice hardline + ^^ string "exit \"$test_exit_code\"" + ^^ hardline + else + empty let save ?(perm = 0o666) (output_dir : string) (filename : string) (doc : Pp.document) @@ -515,7 +567,12 @@ let generate in if List.is_empty insts then failwith "No testable functions"; let filename_base = filename |> Filename.basename |> Filename.chop_extension in - let generators_doc = compile_generators sigma prog5 insts in + let generators_doc = + compile_generators + sigma + prog5 + (List.filter (fun inst -> not (should_be_unit_test sigma inst)) insts) + in let generators_fn = filename_base ^ "_gen.h" in save output_dir generators_fn generators_doc; let tests_doc = diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index 94521760b..fbe7b614e 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -12,7 +12,8 @@ type t = until_timeout : int option; exit_fast : bool; max_stack_depth : int option; - max_generator_size : int option + max_generator_size : int option; + coverage : bool } let default = @@ -27,7 +28,8 @@ let default = until_timeout = None; exit_fast = false; max_stack_depth = None; - max_generator_size = None + max_generator_size = None; + coverage = false } @@ -58,3 +60,5 @@ let is_exit_fast () = !instance.exit_fast let has_max_stack_depth () = !instance.max_stack_depth let has_max_generator_size () = !instance.max_generator_size + +let is_coverage () = !instance.coverage diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index e5a52341e..4981fa1c6 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -12,7 +12,8 @@ type t = until_timeout : int option; exit_fast : bool; max_stack_depth : int option; - max_generator_size : int option + max_generator_size : int option; + coverage : bool } val default : t @@ -42,3 +43,5 @@ val is_exit_fast : unit -> bool val has_max_stack_depth : unit -> int option val has_max_generator_size : unit -> int option + +val is_coverage : unit -> bool From ec552f98d30a70182d2734764aeb01ecf44a268c Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 12 Nov 2024 03:42:27 -0500 Subject: [PATCH 056/148] [CN-Test-Gen] Support `--only` and `--skip` --- backend/cn/bin/main.ml | 15 +++++++++++++ backend/cn/lib/check.ml | 26 +++++++++++++--------- backend/cn/lib/testGeneration/specTests.ml | 12 ++++++---- 3 files changed, 39 insertions(+), 14 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 5b7cf3094..beee98df6 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -433,6 +433,8 @@ let run_tests without_ownership_checking (* Test Generation *) output_dir + only + skip dont_run num_samples max_backtracks @@ -451,6 +453,7 @@ let run_tests (* flags *) Cerb_debug.debug_level := debug_level; Pp.print_level := print_level; + Check.skip_and_only := (opt_comma_split skip, opt_comma_split only); Sym.executable_spec_enabled := true; let handle_error (e : TypeErrors.type_error) = let report = TypeErrors.pp_message e.msg in @@ -876,6 +879,16 @@ module Testing_flags = struct Arg.(required & opt (some string) None & info [ "output-dir" ] ~docv:"FILE" ~doc) + let only = + let doc = "only test this function (or comma-separated names)" in + Arg.(value & opt (some string) None & info [ "only" ] ~doc) + + + let skip = + let doc = "skip testing of this function (or comma-separated names)" in + Arg.(value & opt (some string) None & info [ "skip" ] ~doc) + + let dont_run_tests = let doc = "Do not run tests, only generate them" in Arg.(value & flag & info [ "no-run" ] ~doc) @@ -995,6 +1008,8 @@ let testing_cmd = $ Common_flags.magic_comment_char_dollar $ Executable_spec_flags.without_ownership_checking $ Testing_flags.output_test_dir + $ Testing_flags.only + $ Testing_flags.skip $ Testing_flags.dont_run_tests $ Testing_flags.gen_num_samples $ Testing_flags.gen_backtrack_attempts diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index c9fde5226..d84538a3f 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -2384,24 +2384,27 @@ let c_function_name ((fsym, (_loc, _args_and_body)) : c_function) : string = (** Filter functions according to [skip_and_only]: first according to "only", then according to "skip" *) -let select_functions (funs : c_function list) : c_function list = +let select_functions (fsyms : SymSet.t) : SymSet.t = let matches_str s fsym = String.equal s (Sym.pp_string fsym) in let str_fsyms s = - match List.filter (matches_str s) (List.map fst funs) with - | [] -> + let ss = SymSet.filter (matches_str s) fsyms in + if SymSet.is_empty ss then ( Pp.warn_noloc (!^"function" ^^^ !^s ^^^ !^"not found"); - [] - | ss -> ss + SymSet.empty) + else + ss + in + let strs_fsyms ss = + ss |> List.map str_fsyms |> List.fold_left SymSet.union SymSet.empty in - let strs_fsyms ss = SymSet.of_list (List.concat_map str_fsyms ss) in let skip = strs_fsyms (fst !skip_and_only) in let only = strs_fsyms (snd !skip_and_only) in let only_funs = match snd !skip_and_only with - | [] -> funs - | _ss -> List.filter (fun (fsym, _) -> SymSet.mem fsym only) funs + | [] -> fsyms + | _ss -> SymSet.filter (fun fsym -> SymSet.mem fsym only) fsyms in - List.filter (fun (fsym, _) -> not (SymSet.mem fsym skip)) only_funs + SymSet.filter (fun fsym -> not (SymSet.mem fsym skip)) only_funs (** Check a single C function. Failure of the check is encoded monadically. *) @@ -2464,7 +2467,10 @@ let check_c_functions_all (funs : c_function list) : (string * TypeErrors.t) lis with the name of the function in which they occurred. When [fail_fast] is set, the first error encountered will halt checking. *) let check_c_functions (funs : c_function list) : (string * TypeErrors.t) list m = - let selected_funs = select_functions funs in + let selected_fsyms = select_functions (SymSet.of_list (List.map fst funs)) in + let selected_funs = + List.filter (fun (fsym, _) -> SymSet.mem fsym selected_fsyms) funs + in match !fail_fast with | true -> let@ error_opt = check_c_functions_fast selected_funs in diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index c4a16bbef..b62bb2487 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -558,12 +558,16 @@ let generate := Some (let open Stdlib in open_out "generatorCompilation.log"); + let insts = prog5 |> Core_to_mucore.collect_instrumentation |> fst in + let selected_fsyms = + Check.select_functions + (SymSet.of_list + (List.map (fun (inst : Core_to_mucore.instrumentation) -> inst.fn) insts)) + in let insts = - prog5 - |> Core_to_mucore.collect_instrumentation - |> fst + insts |> List.filter (fun (inst : Core_to_mucore.instrumentation) -> - Option.is_some inst.internal) + Option.is_some inst.internal && SymSet.mem inst.fn selected_fsyms) in if List.is_empty insts then failwith "No testable functions"; let filename_base = filename |> Filename.basename |> Filename.chop_extension in From dfe01d6428451df0d744cd2a99d44d80fb9e7046 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 12 Nov 2024 06:01:44 -0500 Subject: [PATCH 057/148] [CN-Test-Gen] Flag for disabling passes --- backend/cn/bin/main.ml | 22 ++++++++++++++- backend/cn/lib/testGeneration/genOptimize.ml | 28 +++++++++++-------- .../cn/lib/testGeneration/testGenConfig.ml | 8 ++++-- .../cn/lib/testGeneration/testGenConfig.mli | 5 +++- 4 files changed, 48 insertions(+), 15 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index beee98df6..8bf5f3d13 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -449,6 +449,7 @@ let run_tests max_stack_depth max_generator_size coverage + disable_passes = (* flags *) Cerb_debug.debug_level := debug_level; @@ -514,7 +515,8 @@ let run_tests exit_fast; max_stack_depth; max_generator_size; - coverage + coverage; + disable_passes } in TestGeneration.run @@ -989,6 +991,23 @@ module Testing_flags = struct let test_coverage = let doc = "Record coverage of tests" in Arg.(value & flag & info [ "coverage" ] ~doc) + + + let disable_passes = + let doc = "skip this optimization pass (or comma-separated names)" in + Arg.( + value + & opt + (list + (enum + [ ("reorder", "reorder"); + ("picks", "picks"); + ("flatten", "flatten"); + ("consistency", "consistency"); + ("lift_constraints", "lift_constraints") + ])) + [] + & info [ "disable" ] ~doc) end let testing_cmd = @@ -1024,6 +1043,7 @@ let testing_cmd = $ Testing_flags.test_max_stack_depth $ Testing_flags.test_max_generator_size $ Testing_flags.test_coverage + $ Testing_flags.disable_passes in let doc = "Generates RapidCheck tests for all functions in [FILE] with CN specifications.\n\ diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index f224db9f3..8d9bb4183 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -6,6 +6,7 @@ module GT = GenTerms module GS = GenStatements module GD = GenDefinitions module GA = GenAnalysis +module Config = TestGenConfig module SymSet = Set.Make (Sym) module SymMap = Map.Make (Sym) module StringSet = Set.Make (String) @@ -3453,14 +3454,14 @@ module Specialization = struct end let all_passes (prog5 : unit Mucore.file) = - (PartialEvaluation.pass prog5 - :: PushPull.pass - :: MemberIndirection.pass - :: Inline.passes) + [ PartialEvaluation.pass prog5 ] + @ (if Config.has_pass "flatten" then [ PushPull.pass ] else []) + @ [ MemberIndirection.pass ] + @ Inline.passes @ RemoveUnused.passes @ [ TermSimplification.pass prog5; TermSimplification'.pass; PointerOffsets.pass ] @ BranchPruning.passes - @ SplitConstraints.passes + @ if Config.has_pass "lift_constraints" then SplitConstraints.passes else [] let optimize_gen (prog5 : unit Mucore.file) (passes : StringSet.t) (gt : GT.t) : GT.t = @@ -3496,13 +3497,18 @@ let optimize_gen_def (prog5 : unit Mucore.file) (passes : StringSet.t) (gd : GD. |> aux |> Fusion.Each.transform |> aux - |> FlipIfs.transform + |> (if Config.has_pass "picks" then FlipIfs.transform else fun gd' -> gd') |> aux - |> Reordering.transform [] - |> ConstraintPropagation.transform - |> Specialization.Equality.transform - |> Specialization.Integer.transform - |> Specialization.Pointer.transform + |> (if Config.has_pass "reorder" then Reordering.transform [] else fun gd' -> gd') + |> (if Config.has_pass "consistency" then + fun gd' -> + gd' + |> ConstraintPropagation.transform + |> Specialization.Equality.transform + |> Specialization.Integer.transform + |> Specialization.Pointer.transform + else + fun gd' -> gd') |> InferAllocationSize.transform |> aux diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index fbe7b614e..642d20273 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -13,7 +13,8 @@ type t = exit_fast : bool; max_stack_depth : int option; max_generator_size : int option; - coverage : bool + coverage : bool; + disable_passes : string list } let default = @@ -29,7 +30,8 @@ let default = exit_fast = false; max_stack_depth = None; max_generator_size = None; - coverage = false + coverage = false; + disable_passes = [] } @@ -62,3 +64,5 @@ let has_max_stack_depth () = !instance.max_stack_depth let has_max_generator_size () = !instance.max_generator_size let is_coverage () = !instance.coverage + +let has_pass s = not (List.mem String.equal s !instance.disable_passes) diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 4981fa1c6..b09ecf0b6 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -13,7 +13,8 @@ type t = exit_fast : bool; max_stack_depth : int option; max_generator_size : int option; - coverage : bool + coverage : bool; + disable_passes : string list } val default : t @@ -45,3 +46,5 @@ val has_max_stack_depth : unit -> int option val has_max_generator_size : unit -> int option val is_coverage : unit -> bool + +val has_pass : string -> bool From a6430b4c82300ecf8be9d481e2bace59c798bb3d Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 12 Nov 2024 22:06:45 +0000 Subject: [PATCH 058/148] Improve and extend mechanism for extracting relevant information for executable checking (#713) * revise information extraction for executable checking - move that logic to new module - tidy up the extraction types and code - record relevant information for loop invariants * ocamlformat * ocamlformat specTests.ml * ocamlformat specTests.ml --- backend/cn/bin/main.ml | 4 +- backend/cn/lib/check.ml | 2 +- backend/cn/lib/cn_internal_to_ail.ml | 22 +-- backend/cn/lib/cn_internal_to_ail.mli | 2 +- backend/cn/lib/core_to_mucore.ml | 150 ++----------------- backend/cn/lib/core_to_mucore.mli | 30 +--- backend/cn/lib/executable_spec.ml | 4 +- backend/cn/lib/executable_spec_extract.ml | 136 +++++++++++++++++ backend/cn/lib/executable_spec_extract.mli | 41 +++++ backend/cn/lib/executable_spec_internal.ml | 12 +- backend/cn/lib/executable_spec_records.ml | 21 ++- backend/cn/lib/mucore.ml | 2 + backend/cn/lib/mucore.mli | 2 + backend/cn/lib/pp_mucore.ml | 7 +- backend/cn/lib/pp_mucore_ast.ml | 2 +- backend/cn/lib/testGeneration/genCompile.ml | 4 +- backend/cn/lib/testGeneration/genCompile.mli | 2 +- backend/cn/lib/testGeneration/specTests.ml | 30 ++-- backend/cn/lib/wellTyped.ml | 10 +- frontend/model/annot.lem | 2 +- frontend/model/cabs_to_ail.lem | 8 +- frontend/model/cabs_to_ail_effect.lem | 6 +- 22 files changed, 268 insertions(+), 231 deletions(-) create mode 100644 backend/cn/lib/executable_spec_extract.ml create mode 100644 backend/cn/lib/executable_spec_extract.mli diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 8bf5f3d13..d540110a2 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -477,9 +477,9 @@ let run_tests (fun () -> if prog5 - |> Core_to_mucore.collect_instrumentation + |> Executable_spec_extract.collect_instrumentation |> fst - |> List.filter (fun (inst : Core_to_mucore.instrumentation) -> + |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> Option.is_some inst.internal) |> List.is_empty then ( diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index d84538a3f..b90e66e08 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -2162,7 +2162,7 @@ let check_procedure pure (match def with | Mu.Return _loc -> return () - | Label (loc, label_args_and_body, _annots, _) -> + | Label (loc, label_args_and_body, _annots, _, _loop_info) -> debug 2 (lazy diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 4b3af6050..712948f15 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -6,6 +6,7 @@ module CF = Cerb_frontend open CF.Cn open Compile open Executable_spec_utils +module ESE = Executable_spec_extract module A = CF.AilSyntax module C = CF.Ctype module BT = BaseTypes @@ -3135,9 +3136,7 @@ let rec cn_to_ail_post_aux_internal dts globals preds = function | LRT.Define ((name, it), (_loc, _), t) -> (* Printf.printf "LRT.Define\n"; *) let new_name = generate_sym_with_suffix ~suffix:"_cn" name in - let new_lrt = - Core_to_mucore.fn_spec_instrumentation_sym_subst_lrt (name, IT.bt it, new_name) t - in + let new_lrt = LogicalReturnTypes.subst (ESE.sym_subst (name, IT.bt it, new_name)) t in let binding = create_binding new_name (bt_to_ail_ctype (IT.bt it)) in let decl = A.(AilSdeclaration [ (new_name, None) ]) in let b1, s1 = cn_to_ail_expr_internal dts globals it (AssignVar new_name) in @@ -3150,9 +3149,7 @@ let rec cn_to_ail_post_aux_internal dts globals preds = function let b1, s1 = cn_to_ail_resource_internal ~is_pre:false new_name dts globals preds loc re in - let new_lrt = - Core_to_mucore.fn_spec_instrumentation_sym_subst_lrt (name, bt, new_name) t - in + let new_lrt = LogicalReturnTypes.subst (ESE.sym_subst (name, bt, new_name)) t in let b2, s2 = cn_to_ail_post_aux_internal dts globals preds new_lrt in (b1 @ b2, upd_s @ s1 @ pop_s @ s2) | LRT.Constraint (lc, (loc, _str_opt), t) -> @@ -3276,7 +3273,7 @@ let rec cn_to_ail_lat_internal_2 let ctype = bt_to_ail_ctype (IT.bt it) in let new_name = generate_sym_with_suffix ~suffix:"_cn" name in let new_lat = - Core_to_mucore.fn_spec_instrumentation_sym_subst_lat (name, IT.bt it, new_name) lat + ESE.fn_largs_and_body_subst (ESE.sym_subst (name, IT.bt it, new_name)) lat in (* let ctype = mk_ctype C.(Pointer (empty_qualifiers, ctype)) in *) let binding = create_binding new_name ctype in @@ -3299,9 +3296,7 @@ let rec cn_to_ail_lat_internal_2 let b1, s1 = cn_to_ail_resource_internal ~is_pre:true new_name dts globals preds loc ret in - let new_lat = - Core_to_mucore.fn_spec_instrumentation_sym_subst_lat (name, bt, new_name) lat - in + let new_lat = ESE.fn_largs_and_body_subst (ESE.sym_subst (name, bt, new_name)) lat in let ail_executable_spec = cn_to_ail_lat_internal_2 without_ownership_checking @@ -3328,7 +3323,8 @@ let rec cn_to_ail_lat_internal_2 in prepend_to_precondition ail_executable_spec (b1, ss) (* Postcondition *) - | LAT.I (post, stats) -> + | LAT.I (post, (stats, _loop)) -> + (*TODO: handle loops *) let rec remove_duplicates locs stats = match stats with | [] -> [] @@ -3405,9 +3401,7 @@ let rec cn_to_ail_pre_post_aux_internal let binding = create_binding cn_sym cn_ctype in let rhs = wrap_with_convert_to A.(AilEident sym) bt in let decl = A.(AilSdeclaration [ (cn_sym, Some (mk_expr rhs)) ]) in - let subst_at = - Core_to_mucore.fn_spec_instrumentation_sym_subst_at (sym, bt, cn_sym) at - in + let subst_at = ESE.fn_args_and_body_subst (ESE.sym_subst (sym, bt, cn_sym)) at in let ail_executable_spec = cn_to_ail_pre_post_aux_internal without_ownership_checking diff --git a/backend/cn/lib/cn_internal_to_ail.mli b/backend/cn/lib/cn_internal_to_ail.mli index 9c4e995ca..4a600fc7f 100644 --- a/backend/cn/lib/cn_internal_to_ail.mli +++ b/backend/cn/lib/cn_internal_to_ail.mli @@ -172,7 +172,7 @@ val cn_to_ail_pre_post_internal (Sym.t * ResourcePredicates.definition) list -> (Sym.t * C.ctype) list -> C.ctype -> - Core_to_mucore.fn_spec_instrumentation option -> + Executable_spec_extract.fn_args_and_body option -> ail_executable_spec val cn_to_ail_assume_predicates_internal diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 17ffcce7f..4bc21a128 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -1139,9 +1139,9 @@ let normalise_label | Mi_Label (loc, lt, label_args, label_body, annots) -> (match CF.Annot.get_label_annot annots with | Some (LAloop loop_id) -> - let@ desugared_inv, cn_desugaring_state = + let@ desugared_inv, cn_desugaring_state, loop_condition_loc = match Pmap.lookup loop_id loop_attributes with - | Some (marker_id, attrs) -> + | Some (marker_id, attrs, loop_condition_loc) -> let@ inv = Parse.loop_spec attrs in let d_st = CAE. @@ -1153,8 +1153,9 @@ let normalise_label } in let@ inv, d_st = desugar_conds d_st inv in - return (inv, d_st.inner.cn_state) - | None -> return ([], precondition_cn_desugaring_state) + return (inv, d_st.inner.cn_state, loop_condition_loc) + | None -> assert false + (* return ([], precondition_cn_desugaring_state) *) in debug 6 (lazy (!^"invariant in function" ^^^ Sym.pp fsym)); debug 6 (lazy (CF.Pp_ast.pp_doc_tree (dtree_of_inv desugared_inv))); @@ -1179,7 +1180,12 @@ let normalise_label (* ) label_args_and_body *) (* in *) return - (Mu.Label (loc, label_args_and_body, annots, { label_spec = desugared_inv })) + (Mu.Label + ( loc, + label_args_and_body, + annots, + { label_spec = desugared_inv }, + `Loop loop_condition_loc )) (* | Some (LAloop_body _loop_id) -> *) (* assert_error loc !^"body label has not been inlined" *) | Some (LAloop_continue _loop_id) -> @@ -1591,137 +1597,3 @@ let normalise_file ~inherit_loc ((fin_markers_env : CAE.fin_markers_env), ail_pr in debug 3 (lazy (headline "done core_to_mucore normalising file")); return file - - -(* type internal = { pre: unit arguments; post: ReturnTypes.t; inv: (Loc.t * unit - arguments); statements: (Locations.t * Cnprog.cn_prog list) list; } *) - -type statements = (Locations.t * Cnprog.t list) list - -type fn_spec_instrumentation = (ReturnTypes.t * statements) ArgumentTypes.t - -type instrumentation = - { fn : Sym.t; - fn_loc : Locations.t; - internal : fn_spec_instrumentation option - } - -let rt_stmts_subst subst (rt, stmts) = - let rt = ReturnTypes.subst subst rt in - let stmts = - List.map (fun (loc, cn_progs) -> (loc, List.map (Cnprog.subst subst) cn_progs)) stmts - in - (rt, stmts) - - -let fn_spec_instrumentation_subst_at - : _ Subst.t -> fn_spec_instrumentation -> fn_spec_instrumentation - = - ArgumentTypes.subst rt_stmts_subst - - -let fn_spec_instrumentation_subst_lat - : _ Subst.t -> (ReturnTypes.t * statements) LogicalArgumentTypes.t -> - (ReturnTypes.t * statements) LogicalArgumentTypes.t - = - LogicalArgumentTypes.subst rt_stmts_subst - - -(* substitute `s_with` for `s_replace` of basetype `bt` *) -let fn_spec_instrumentation_sym_subst_at (s_replace, bt, s_with) fn_spec = - let subst = - IT.make_subst [ (s_replace, IT.sym_ (s_with, bt, Cerb_location.unknown)) ] - in - fn_spec_instrumentation_subst_at subst fn_spec - - -let fn_spec_instrumentation_sym_subst_lat (s_replace, bt, s_with) fn_spec = - let subst = - IT.make_subst [ (s_replace, IT.sym_ (s_with, bt, Cerb_location.unknown)) ] - in - fn_spec_instrumentation_subst_lat subst fn_spec - - -let fn_spec_instrumentation_sym_subst_lrt (s_replace, bt, s_with) fn_spec = - let subst = - IT.make_subst [ (s_replace, IT.sym_ (s_with, bt, Cerb_location.unknown)) ] - in - LRT.subst subst fn_spec - - -let concat2 (x : 'a list * 'b list) (y : 'a list * 'b list) : 'a list * 'b list = - let a1, b1 = x in - let a2, b2 = y in - (a1 @ a2, b1 @ b2) - - -let concat2_map (f : 'a -> 'b list * 'c list) (xs : 'a list) : 'b list * 'c list = - List.fold_right (fun x acc -> concat2 (f x) acc) xs ([], []) - - -let rec stmts_in_expr (Mu.Expr (loc, _, _, e_)) = - match e_ with - | Epure _ -> ([], []) - | Ememop _ -> ([], []) - | Eaction _ -> ([], []) - | Eskip -> ([], []) - | Eccall _ -> ([], []) - | Elet (_, _, e) -> stmts_in_expr e - | Eunseq es -> concat2_map stmts_in_expr es - | Ewseq (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) - | Esseq (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) - | Eif (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) - | Ebound e -> stmts_in_expr e - | End es -> concat2_map stmts_in_expr es - | Erun _ -> ([], []) - | CN_progs (stmts_s, stmts_i) -> ([ (loc, stmts_s) ], [ (loc, stmts_i) ]) - - -let rec stmts_in_largs f_i = function - | Mu.Define (_, _, a) -> stmts_in_largs f_i a - | Resource (_, _, a) -> stmts_in_largs f_i a - | Constraint (_, _, a) -> stmts_in_largs f_i a - | I i -> f_i i - - -let rec stmts_in_args f_i = function - | Mu.Computational (_, _, a) -> stmts_in_args f_i a - | L a -> stmts_in_largs f_i a - - -let stmts_in_labels labels = - Pmap.fold - (fun _s def acc -> - match def with - | Mu.Return _ -> acc - | Label (_, a, _, _) -> concat2 (stmts_in_args stmts_in_expr a) acc) - labels - ([], []) - - -(* - * let stmts_in_function args_and_body = - * stmts_in_args - * (fun (body, labels, _rt) -> concat2 (stmts_in_expr body) (stmts_in_labels labels)) - * args_and_body - *) - -let collect_instrumentation (file : _ Mu.file) = - let instrs = - List.map - (fun (fn, decl) -> - match decl with - | Mu.Proc { loc = fn_loc; args_and_body; _ } -> - let args_and_body = at_of_arguments Fun.id args_and_body in - let internal = - ArgumentTypes.map - (fun (body, labels, rt) -> - let _, stmts = concat2 (stmts_in_expr body) (stmts_in_labels labels) in - (rt, stmts)) - args_and_body - in - { fn; fn_loc; internal = Some internal } - | ProcDecl (fn_loc, _fn) -> { fn; fn_loc; internal = None }) - (Pmap.bindings_list file.funs) - in - (instrs, C.symtable) diff --git a/backend/cn/lib/core_to_mucore.mli b/backend/cn/lib/core_to_mucore.mli index a867d7d43..87a154a61 100644 --- a/backend/cn/lib/core_to_mucore.mli +++ b/backend/cn/lib/core_to_mucore.mli @@ -7,34 +7,6 @@ val normalise_file ('b, unit) Cerb_frontend.Milicore.mi_file -> unit Mucore.file Resultat.m -(* TODO(RB) - Do these belong here? Looks like they can/should be factored out *) -type statements = (Locations.t * Cnprog.t list) list - -type fn_spec_instrumentation = (ReturnTypes.t * statements) ArgumentTypes.t - val arguments_of_at : ('a -> 'b) -> 'a ArgumentTypes.t -> 'b Mucore.arguments -val fn_spec_instrumentation_sym_subst_lrt - : Sym.t * BaseTypes.t * Sym.t -> - LogicalReturnTypes.t -> - LogicalReturnTypes.t - -val fn_spec_instrumentation_sym_subst_lat - : Sym.t * BaseTypes.t * Sym.t -> - (ReturnTypes.t * statements) LogicalArgumentTypes.t -> - (ReturnTypes.t * statements) LogicalArgumentTypes.t - -val fn_spec_instrumentation_sym_subst_at - : Sym.t * BaseTypes.t * Sym.t -> - fn_spec_instrumentation -> - fn_spec_instrumentation - -type instrumentation = - { fn : Sym.t; - fn_loc : Locations.t; - internal : fn_spec_instrumentation option - } - -val collect_instrumentation - : 'a Mucore.file -> - instrumentation list * BaseTypes.Surface.t Hashtbl.Make(Sym).t +val at_of_arguments : ('b -> 'a) -> 'b Mucore.arguments -> 'a ArgumentTypes.t diff --git a/backend/cn/lib/executable_spec.ml b/backend/cn/lib/executable_spec.ml index 02fc3c9d7..9a0a7b37e 100644 --- a/backend/cn/lib/executable_spec.ml +++ b/backend/cn/lib/executable_spec.ml @@ -213,7 +213,9 @@ let main let oc = Stdlib.open_out (Filename.concat prefix output_filename) in let cn_oc = Stdlib.open_out (Filename.concat prefix "cn.c") in let cn_header_oc = Stdlib.open_out (Filename.concat prefix "cn.h") in - let instrumentation, symbol_table = Core_to_mucore.collect_instrumentation prog5 in + let instrumentation, symbol_table = + Executable_spec_extract.collect_instrumentation prog5 + in Executable_spec_records.populate_record_map instrumentation prog5; let executable_spec = generate_c_specs_internal diff --git a/backend/cn/lib/executable_spec_extract.ml b/backend/cn/lib/executable_spec_extract.ml new file mode 100644 index 000000000..3474d693f --- /dev/null +++ b/backend/cn/lib/executable_spec_extract.ml @@ -0,0 +1,136 @@ +open Mucore + +type statement = Locations.t * Cnprog.t list + +let statement_subst subst ((loc, cnprogs) : statement) : statement = + (loc, List.map (Cnprog.subst subst) cnprogs) + + +type statements = statement list + +let statements_subst subst = List.map (statement_subst subst) + +type loop = Locations.t * statements ArgumentTypes.t + +let loop_subst subst ((loc, at) : loop) = + (loc, ArgumentTypes.subst statements_subst subst at) + + +type loops = loop list + +let loops_subst subst = List.map (loop_subst subst) + +type fn_body = statements * loops + +let fn_body_subst subst ((statements, loops) : fn_body) = + (statements_subst subst statements, loops_subst subst loops) + + +type fn_rt_and_body = ReturnTypes.t * fn_body + +let fn_rt_and_body_subst subst ((rt, fn_body) : fn_rt_and_body) = + (ReturnTypes.subst subst rt, fn_body_subst subst fn_body) + + +type fn_args_and_body = fn_rt_and_body ArgumentTypes.t + +let fn_args_and_body_subst subst (at : fn_args_and_body) : fn_args_and_body = + ArgumentTypes.subst fn_rt_and_body_subst subst at + + +type fn_largs_and_body = fn_rt_and_body LogicalArgumentTypes.t + +let fn_largs_and_body_subst subst (lat : fn_largs_and_body) : fn_largs_and_body = + LogicalArgumentTypes.subst fn_rt_and_body_subst subst lat + + +type instrumentation = + { fn : Sym.t; + fn_loc : Locations.t; + internal : fn_args_and_body option + } + +(* replace `s_replace` of basetype `bt` with `s_with` *) +let sym_subst (s_replace, bt, s_with) = + let module IT = IndexTerms in + IT.make_subst [ (s_replace, IT.sym_ (s_with, bt, Cerb_location.unknown)) ] + + +(** +let concat2 (x : 'a list * 'b list) (y : 'a list * 'b list) : 'a list * 'b list = + let a1, b1 = x in + let a2, b2 = y in + (a1 @ a2, b1 @ b2) + + +let concat2_map (f : 'a -> 'b list * 'c list) (xs : 'a list) : 'b list * 'c list = + List.fold_right (fun x acc -> concat2 (f x) acc) xs ([], []) + + +let rec stmts_in_expr (Mucore.Expr (loc, _, _, e_)) = + match e_ with + | Epure _ -> ([], []) + | Ememop _ -> ([], []) + | Eaction _ -> ([], []) + | Eskip -> ([], []) + | Eccall _ -> ([], []) + | Elet (_, _, e) -> stmts_in_expr e + | Eunseq es -> concat2_map stmts_in_expr es + | Ewseq (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) + | Esseq (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) + | Eif (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) + | Ebound e -> stmts_in_expr e + | End es -> concat2_map stmts_in_expr es + | Erun _ -> ([], []) + | CN_progs (stmts_s, stmts_i) -> ([ (loc, stmts_s) ], [ (loc, stmts_i) ]) +*) + +let rec stmts_in_expr (Mucore.Expr (loc, _, _, e_)) = + match e_ with + | Epure _ -> [] + | Ememop _ -> [] + | Eaction _ -> [] + | Eskip -> [] + | Eccall _ -> [] + | Elet (_, _, e) -> stmts_in_expr e + | Eunseq es -> List.concat_map stmts_in_expr es + | Ewseq (_, e1, e2) -> stmts_in_expr e1 @ stmts_in_expr e2 + | Esseq (_, e1, e2) -> stmts_in_expr e1 @ stmts_in_expr e2 + | Eif (_, e1, e2) -> stmts_in_expr e1 @ stmts_in_expr e2 + | Ebound e -> stmts_in_expr e + | End es -> List.concat_map stmts_in_expr es + | Erun _ -> [] + | CN_progs (_stmts_s, stmts_i) -> [ (loc, stmts_i) ] + + +let from_loop ((_label_sym : Sym.t), (label_def : _ label_def)) : loop option = + match label_def with + | Return _ -> None + | Label (_loc, label_args_and_body, _annots, _, `Loop loop_condition_loc) -> + let label_args_and_body = Core_to_mucore.at_of_arguments Fun.id label_args_and_body in + let label_args_and_statements = ArgumentTypes.map stmts_in_expr label_args_and_body in + Some (loop_condition_loc, label_args_and_statements) + + +let from_fn (fn, decl) = + match decl with + | ProcDecl (fn_loc, _fn) -> { fn; fn_loc; internal = None } + | Proc { loc = fn_loc; args_and_body; _ } -> + let args_and_body = Core_to_mucore.at_of_arguments Fun.id args_and_body in + let internal = + ArgumentTypes.map + (fun (body, labels, rt) -> + let stmts = stmts_in_expr body in + let loops = List.filter_map from_loop (Pmap.bindings_list labels) in + (rt, (stmts, loops))) + args_and_body + in + { fn; fn_loc; internal = Some internal } + + +let from_file (file : _ Mucore.file) = + let instrs = List.map from_fn (Pmap.bindings_list file.funs) in + (instrs, Compile.symtable) + + +let collect_instrumentation = from_file diff --git a/backend/cn/lib/executable_spec_extract.mli b/backend/cn/lib/executable_spec_extract.mli new file mode 100644 index 000000000..9844565f1 --- /dev/null +++ b/backend/cn/lib/executable_spec_extract.mli @@ -0,0 +1,41 @@ +type statement = Locations.t * Cnprog.t list + +type statements = statement list + +type loop = + Locations.t * statements ArgumentTypes.t (* location is for the loop condition *) + +type loops = loop list + +type fn_body = statements * loops + +type fn_args_and_body = (ReturnTypes.t * fn_body) ArgumentTypes.t + +type fn_largs_and_body = (ReturnTypes.t * fn_body) LogicalArgumentTypes.t + +(* type fn_spec_instrumentation = (ReturnTypes.t * statements) ArgumentTypes.t *) +(* type fn_spec_instrumentation_lat = (ReturnTypes.t * statements) LogicalArgumentTypes.t *) + +val sym_subst + : Sym.t * BaseTypes.t * Sym.t -> + [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t + +val fn_args_and_body_subst + : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> + fn_args_and_body -> + fn_args_and_body + +val fn_largs_and_body_subst + : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> + fn_largs_and_body -> + fn_largs_and_body + +type instrumentation = + { fn : Sym.t; + fn_loc : Locations.t; + internal : fn_args_and_body option + } + +val collect_instrumentation + : 'a Mucore.file -> + instrumentation list * BaseTypes.Surface.t Hashtbl.Make(Sym).t diff --git a/backend/cn/lib/executable_spec_internal.ml b/backend/cn/lib/executable_spec_internal.ml index 36b8dfa40..2c390f528 100644 --- a/backend/cn/lib/executable_spec_internal.ml +++ b/backend/cn/lib/executable_spec_internal.ml @@ -56,7 +56,7 @@ let rec extract_global_variables = function let generate_c_pres_and_posts_internal without_ownership_checking - (instrumentation : Core_to_mucore.instrumentation) + (instrumentation : Executable_spec_extract.instrumentation) _ (sigm : _ CF.AilSyntax.sigma) (prog5 : unit Mucore.file) @@ -151,11 +151,11 @@ let generate_c_pres_and_posts_internal let generate_c_assume_pres_internal - (instrumentation_list : Core_to_mucore.instrumentation list) + (instrumentation_list : Executable_spec_extract.instrumentation list) (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) = - let aux (inst : Core_to_mucore.instrumentation) = + let aux (inst : Executable_spec_extract.instrumentation) = let dts = sigma.cn_datatypes in let preds = prog5.resource_predicates in let args = @@ -176,12 +176,12 @@ let generate_c_assume_pres_internal (AT.get_lat (Option.get inst.internal)) in instrumentation_list - |> List.filter (fun (inst : Core_to_mucore.instrumentation) -> + |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> Option.is_some inst.internal) |> List.map aux -(* Core_to_mucore.instrumentation list -> executable_spec *) +(* Executable_spec_extract.instrumentation list -> executable_spec *) let generate_c_specs_internal without_ownership_checking instrumentation_list @@ -190,7 +190,7 @@ let generate_c_specs_internal (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) (prog5 : unit Mucore.file) = - let generate_c_spec (instrumentation : Core_to_mucore.instrumentation) = + let generate_c_spec (instrumentation : Executable_spec_extract.instrumentation) = generate_c_pres_and_posts_internal without_ownership_checking instrumentation diff --git a/backend/cn/lib/executable_spec_records.ml b/backend/cn/lib/executable_spec_records.ml index ce97ff338..125b6208e 100644 --- a/backend/cn/lib/executable_spec_records.ml +++ b/backend/cn/lib/executable_spec_records.ml @@ -83,7 +83,7 @@ let add_records_to_map_from_cnprogs (_, cn_progs) = List.iter aux cn_progs -let add_records_to_map_from_instrumentation (i : Core_to_mucore.instrumentation) = +let add_records_to_map_from_instrumentation (i : Executable_spec_extract.instrumentation) = let rec aux_lrt = function | LRT.Define ((_, it), _, t) -> add_records_to_map_from_it it; @@ -96,6 +96,7 @@ let add_records_to_map_from_instrumentation (i : Core_to_mucore.instrumentation) aux_lrt t | I -> () in + let aux_rt = function ReturnTypes.Computational (_, _, t) -> aux_lrt t in let rec aux_lat = function | LAT.Define ((_, it), _, lat) -> add_records_to_map_from_it it; @@ -107,15 +108,23 @@ let add_records_to_map_from_instrumentation (i : Core_to_mucore.instrumentation) add_records_to_map_from_lc lc; aux_lat lat (* Postcondition *) - | I (ReturnTypes.Computational (_, _, t), stats) -> - List.iter add_records_to_map_from_cnprogs stats; - aux_lrt t + | I i -> i in let rec aux_at = function | AT.Computational ((_, _), _, at) -> aux_at at | L lat -> aux_lat lat in - match i.internal with Some instr -> aux_at instr | None -> () + match i.internal with + | None -> () + | Some instr -> + let rt, (stmts, loops) = aux_at instr in + aux_rt rt; + List.iter add_records_to_map_from_cnprogs stmts; + List.iter + (fun (_loc, loop_at) -> + let loop_stmts = aux_at loop_at in + List.iter add_records_to_map_from_cnprogs loop_stmts) + loops let rec populate ?cn_sym bt = @@ -167,7 +176,7 @@ let add_records_to_map_from_struct (tag_def : Mucore.tag_definition) = (* Populate record table *) let populate_record_map - (instrumentation : Core_to_mucore.instrumentation list) + (instrumentation : Executable_spec_extract.instrumentation list) (prog5 : unit Mucore.file) = add_records_to_map_from_fns_and_preds prog5.logical_predicates prog5.resource_predicates; diff --git a/backend/cn/lib/mucore.ml b/backend/cn/lib/mucore.ml index 66d7dd68f..43cf4a3a3 100644 --- a/backend/cn/lib/mucore.ml +++ b/backend/cn/lib/mucore.ml @@ -380,6 +380,8 @@ type 'TY label_def = * 'TY expr arguments * Cerb_frontend.Annot.annot list * parse_ast_label_spec + * [ `Loop of Locations.t ] +(*loop condition location, for executable checking *) type trusted = | Trusted of Locations.t diff --git a/backend/cn/lib/mucore.mli b/backend/cn/lib/mucore.mli index d0734931c..6a247aa8a 100644 --- a/backend/cn/lib/mucore.mli +++ b/backend/cn/lib/mucore.mli @@ -283,6 +283,8 @@ type 'TY label_def = * 'TY expr arguments * Cerb_frontend.Annot.annot list * parse_ast_label_spec + * [ `Loop of Locations.t ] +(*loop condition location, for executable checking *) type trusted = | Trusted of Locations.t diff --git a/backend/cn/lib/pp_mucore.ml b/backend/cn/lib/pp_mucore.ml index 312d8b1d0..30ffcecf7 100644 --- a/backend/cn/lib/pp_mucore.ml +++ b/backend/cn/lib/pp_mucore.ml @@ -699,7 +699,12 @@ module Make (Config : CONFIG) = struct ^^ (match def with | Return _ -> P.break 1 ^^ !^"return label" ^^^ pp_symbol sym - | Label (_loc, label_args_and_body, _annots, _) -> + | Label + ( _loc, + label_args_and_body, + _annots, + _, + _loop_condition_loc ) -> P.break 1 ^^ !^"label" ^^^ pp_symbol sym diff --git a/backend/cn/lib/pp_mucore_ast.ml b/backend/cn/lib/pp_mucore_ast.ml index 3163fe93e..3792111e9 100644 --- a/backend/cn/lib/pp_mucore_ast.ml +++ b/backend/cn/lib/pp_mucore_ast.ml @@ -241,7 +241,7 @@ module PP = struct let dtree_of_label l def = match def with | Return loc -> Dleaf (!^"return" ^^^ Cerb_location.pp_location ~clever:false loc) - | Label (loc, args_and_body, _, _) -> + | Label (loc, args_and_body, _, _, _) -> Dnode ( pp_symbol l ^^^ Cerb_location.pp_location ~clever:false loc, [ dtree_of_arguments dtree_of_expr args_and_body ] ) diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index e0b2acb66..1036a6db9 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -377,13 +377,13 @@ let compile_spec let compile ?(ctx : GD.context option) (preds : (Sym.t * RP.definition) list) - (insts : Core_to_mucore.instrumentation list) + (insts : Executable_spec_extract.instrumentation list) : GD.context = let recursive_preds = GenAnalysis.get_recursive_preds preds in let context_specs = insts - |> List.map (fun (inst : Core_to_mucore.instrumentation) -> + |> List.map (fun (inst : Executable_spec_extract.instrumentation) -> compile_spec (Option.get (Cerb_location.get_filename inst.fn_loc)) recursive_preds diff --git a/backend/cn/lib/testGeneration/genCompile.mli b/backend/cn/lib/testGeneration/genCompile.mli index 81d611e08..4f4f2ce22 100644 --- a/backend/cn/lib/testGeneration/genCompile.mli +++ b/backend/cn/lib/testGeneration/genCompile.mli @@ -1,5 +1,5 @@ val compile : ?ctx:GenDefinitions.context -> (Sym.t * ResourcePredicates.definition) list -> - Core_to_mucore.instrumentation list -> + Executable_spec_extract.instrumentation list -> GenDefinitions.context diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index b62bb2487..2c65d30ea 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -39,11 +39,11 @@ let pp_label ?(width : int = 30) (label : string) : Pp.document = ^^ repeat width slash -let compile_unit_tests (insts : Core_to_mucore.instrumentation list) = +let compile_unit_tests (insts : Executable_spec_extract.instrumentation list) = let open Pp in separate_map (semi ^^ twice hardline) - (fun (inst : Core_to_mucore.instrumentation) -> + (fun (inst : Executable_spec_extract.instrumentation) -> CF.Pp_ail.pp_statement A.( Utils.mk_stmt @@ -58,7 +58,7 @@ let compile_unit_tests (insts : Core_to_mucore.instrumentation list) = let compile_generators (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) - (insts : Core_to_mucore.instrumentation list) + (insts : Executable_spec_extract.instrumentation list) : PPrint.document = let ctx = GenCompile.compile prog5.resource_predicates insts in @@ -80,7 +80,7 @@ let compile_random_test_case (prog5 : unit Mucore.file) (args_map : (Sym.t * (Sym.t * C.ctype) list) list) (convert_from : Sym.t * C.ctype -> Pp.document) - (inst : Core_to_mucore.instrumentation) + (inst : Executable_spec_extract.instrumentation) : Pp.document = let open Pp in @@ -177,17 +177,17 @@ let compile_random_test_case let compile_random_tests (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) - (insts : Core_to_mucore.instrumentation list) + (insts : Executable_spec_extract.instrumentation list) : Pp.document = let declarations : A.sigma_declaration list = insts - |> List.map (fun (inst : Core_to_mucore.instrumentation) -> + |> List.map (fun (inst : Executable_spec_extract.instrumentation) -> (inst.fn, List.assoc Sym.equal inst.fn sigma.declarations)) in let args_map : (Sym.t * (Sym.t * C.ctype) list) list = List.map - (fun (inst : Core_to_mucore.instrumentation) -> + (fun (inst : Executable_spec_extract.instrumentation) -> ( inst.fn, let _, _, _, xs, _ = List.assoc Sym.equal inst.fn sigma.function_definitions in match List.assoc Sym.equal inst.fn declarations with @@ -222,7 +222,7 @@ let compile_assumes ~(without_ownership_checking : bool) (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) - (insts : Core_to_mucore.instrumentation list) + (insts : Executable_spec_extract.instrumentation list) : Pp.document = let declarations, function_definitions = @@ -262,7 +262,7 @@ let compile_assumes let should_be_unit_test (sigma : CF.GenTypes.genTypeCategory A.sigma) - (inst : Core_to_mucore.instrumentation) + (inst : Executable_spec_extract.instrumentation) = let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in match decl with @@ -278,7 +278,7 @@ let compile_tests (filename_base : string) (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) - (insts : Core_to_mucore.instrumentation list) + (insts : Executable_spec_extract.instrumentation list) = let unit_tests, random_tests = List.partition (should_be_unit_test sigma) insts in let unit_tests_doc = compile_unit_tests unit_tests in @@ -334,7 +334,7 @@ let compile_tests ^^ semi ^^ hardline) (List.map - (fun (inst : Core_to_mucore.instrumentation) -> + (fun (inst : Executable_spec_extract.instrumentation) -> (inst.fn, List.assoc Sym.equal inst.fn sigma.declarations)) insts) ^^ string "return cn_test_main(argc, argv);") @@ -558,15 +558,17 @@ let generate := Some (let open Stdlib in open_out "generatorCompilation.log"); - let insts = prog5 |> Core_to_mucore.collect_instrumentation |> fst in + let insts = prog5 |> Executable_spec_extract.collect_instrumentation |> fst in let selected_fsyms = Check.select_functions (SymSet.of_list - (List.map (fun (inst : Core_to_mucore.instrumentation) -> inst.fn) insts)) + (List.map + (fun (inst : Executable_spec_extract.instrumentation) -> inst.fn) + insts)) in let insts = insts - |> List.filter (fun (inst : Core_to_mucore.instrumentation) -> + |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> Option.is_some inst.internal && SymSet.mem inst.fn selected_fsyms) in if List.is_empty insts then failwith "No testable functions"; diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index f6e863433..58f885352 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -2193,7 +2193,7 @@ module WProc = struct match def with | Return loc -> (AT.of_rt function_rt (LAT.I False.False), CF.Annot.LAreturn, loc) - | Label (loc, label_args_and_body, annots, _parsed_spec) -> + | Label (loc, label_args_and_body, annots, _parsed_spec, _loop_condition_loc) -> let lt = WLabel.typ label_args_and_body in let kind = Option.get (CF.Annot.get_label_annot annots) in (lt, kind, loc) @@ -2218,13 +2218,13 @@ module WProc = struct (fun _sym def -> match def with | Return loc -> return (Return loc) - | Label (loc, label_args_and_body, annots, parsed_spec) -> + | Label (loc, label_args_and_body, annots, parsed_spec, loop_info) -> let@ label_args_and_body = pure_and_no_initial_resources loc (WLabel.welltyped loc label_args_and_body) in - return (Label (loc, label_args_and_body, annots, parsed_spec))) + return (Label (loc, label_args_and_body, annots, parsed_spec, loop_info))) labels Sym.compare in @@ -2234,7 +2234,7 @@ module WProc = struct (fun _sym def -> match def with | Return loc -> return (Return loc) - | Label (loc, label_args_and_body, annots, parsed_spec) -> + | Label (loc, label_args_and_body, annots, parsed_spec, loop_info) -> let@ label_args_and_body = pure_and_no_initial_resources loc @@ -2245,7 +2245,7 @@ module WProc = struct loc label_args_and_body) in - return (Label (loc, label_args_and_body, annots, parsed_spec))) + return (Label (loc, label_args_and_body, annots, parsed_spec, loop_info))) labels Sym.compare in diff --git a/frontend/model/annot.lem b/frontend/model/annot.lem index fe7301d32..0314fa44d 100644 --- a/frontend/model/annot.lem +++ b/frontend/model/annot.lem @@ -89,7 +89,7 @@ type identifier_item_kind = type identifier_env = map Symbol.identifier (maybe (identifier_item_kind * Symbol.sym)) -type loop_attributes = map loop_id (nat * attributes) (* nat is marker id *) +type loop_attributes = map loop_id (nat * attributes * Loc.t) (* nat is marker id, loc is location of loop condition *) val get_loc: list annot -> maybe Loc.t let rec get_loc annots = diff --git a/frontend/model/cabs_to_ail.lem b/frontend/model/cabs_to_ail.lem index f0cb2df2c..114260456 100644 --- a/frontend/model/cabs_to_ail.lem +++ b/frontend/model/cabs_to_ail.lem @@ -3716,7 +3716,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.return (d_e, d_s) end >>= fun (d_e, d_s) -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs >>= fun () -> + E.record_loop_attribute loop_id attrs (Loc.locOf e) >>= fun () -> if has_continue s then (* while (E) S ==> while (E) { S; cont: ;} *) E.return begin @@ -3748,7 +3748,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.return (d_e, d_s) end >>= fun (d_e, d_s) -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs >>= fun () -> + E.record_loop_attribute loop_id attrs (Loc.locOf e) >>= fun () -> if has_continue s then (* do S (E) ==> do { S; cont: ;} (E) *) E.return begin @@ -3779,7 +3779,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = desugar_init_declarator attrs isAtomic (specifs.alignment_specifiers <> []) base_qs base_ty specifs.storage_classes init ) idecltors >>= fun xs -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs_outer >> + E.record_loop_attribute loop_id attrs_outer (match e2_opt with Just e2 -> Loc.locOf e2 | Nothing -> Loc.unknown end) >> (* for each [init_declarator] *) E.foldrM (fun opt (acc1, acc2) -> match opt with @@ -3876,7 +3876,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.register_label cont_ident >> E.resolve_label cont_ident >>= fun cont_sym -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs >> + E.record_loop_attribute loop_id attrs (match e2_opt with Just e2 -> Loc.locOf e2 | Nothing -> Loc.unknown end) >> let ctx' = <| cont_ident_opt= Just cont_ident |> in diff --git a/frontend/model/cabs_to_ail_effect.lem b/frontend/model/cabs_to_ail_effect.lem index 71d9f0fb7..3bd9d292d 100644 --- a/frontend/model/cabs_to_ail_effect.lem +++ b/frontend/model/cabs_to_ail_effect.lem @@ -1302,11 +1302,11 @@ let register_cn_datatype magic_loc ident loc mk_cases = -val record_loop_attribute: Annot.loop_id -> Annot.attributes -> desugM unit -let record_loop_attribute id attr = +val record_loop_attribute: Annot.loop_id -> Annot.attributes -> Loc.t -> desugM unit +let record_loop_attribute id attr loc = record_marker () >>= fun marker_id -> get_inner >>= fun st -> - put_inner <|st with loop_attributes = (Map.insert id (marker_id, attr) st.loop_attributes) |> + put_inner <|st with loop_attributes = (Map.insert id (marker_id, attr, loc) st.loop_attributes) |> val get_loop_attributes: unit -> desugM Annot.loop_attributes let get_loop_attributes () = From 144eca10446b34d6354e37981777f18429cebf6d Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 6 Nov 2024 18:47:34 +0000 Subject: [PATCH 059/148] Adjust caching in workflows --- .github/workflows/ci-cheri.yml | 22 ++------------------- .github/workflows/ci-cn-bench.yml | 18 ++--------------- .github/workflows/ci-cn-spec-testing.yml | 17 ++-------------- .github/workflows/ci-cn.yml | 17 ++-------------- .github/workflows/ci-pr-bench.yml.disabled | 23 +--------------------- .github/workflows/ci.yml | 10 +++++++++- 6 files changed, 18 insertions(+), 89 deletions(-) diff --git a/.github/workflows/ci-cheri.yml b/.github/workflows/ci-cheri.yml index da46b4174..479694e01 100644 --- a/.github/workflows/ci-cheri.yml +++ b/.github/workflows/ci-cheri.yml @@ -30,7 +30,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt install build-essential libgmp-dev opam + sudo apt-get install build-essential libgmp-dev opam - name: Restore cached opam id: cache-opam-restore @@ -38,25 +38,7 @@ jobs: with: path: ~/.opam key: ${{ matrix.version }} - - - name: Setup opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - run: | - eval $(opam env --switch=with_coq) - opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released - opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git - opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git - opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git - opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - - - name: Save cached opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - id: cache-opam-save - uses: actions/cache/save@v4 - with: - path: ~/.opam - key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + fail-on-cache-miss: true - name: Install Cerberus-CHERI if: ${{ matrix.version == '4.14.1' }} diff --git a/.github/workflows/ci-cn-bench.yml b/.github/workflows/ci-cn-bench.yml index 4acda0fcd..d7111a663 100644 --- a/.github/workflows/ci-cn-bench.yml +++ b/.github/workflows/ci-cn-bench.yml @@ -35,7 +35,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt install build-essential libgmp-dev z3 opam jq + sudo apt-get install build-essential libgmp-dev z3 opam jq - name: Restore cached opam id: cache-opam-restore @@ -43,21 +43,7 @@ jobs: with: path: ~/.opam key: ${{ matrix.version }} - - - name: Setup opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - run: | - opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} - opam install --deps-only --yes ./cerberus-lib.opam - opam switch create with_coq ${{ matrix.version }} - - - name: Save cached opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - id: cache-opam-save - uses: actions/cache/save@v4 - with: - path: ~/.opam - key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + fail-on-cache-miss: true - name: Install Cerberus run: | diff --git a/.github/workflows/ci-cn-spec-testing.yml b/.github/workflows/ci-cn-spec-testing.yml index 0be117ca0..69166b5ef 100644 --- a/.github/workflows/ci-cn-spec-testing.yml +++ b/.github/workflows/ci-cn-spec-testing.yml @@ -31,7 +31,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt install build-essential libgmp-dev z3 opam cmake + sudo apt-get install build-essential libgmp-dev z3 opam cmake - name: Restore cached opam id: cache-opam-restore @@ -39,20 +39,7 @@ jobs: with: path: ~/.opam key: ${{ matrix.version }} - - - name: Setup opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - run: | - opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} - opam install --deps-only --yes ./cerberus-lib.opam - - - name: Save cached opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - id: cache-opam-save - uses: actions/cache/save@v4 - with: - path: ~/.opam - key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + fail-on-cache-miss: true - name: Install Cerberus run: | diff --git a/.github/workflows/ci-cn.yml b/.github/workflows/ci-cn.yml index 98ced7836..7889d279c 100644 --- a/.github/workflows/ci-cn.yml +++ b/.github/workflows/ci-cn.yml @@ -29,7 +29,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt install build-essential libgmp-dev z3 opam + sudo apt-get install build-essential libgmp-dev z3 opam - name: Restore cached opam id: cache-opam-restore @@ -37,20 +37,7 @@ jobs: with: path: ~/.opam key: ${{ matrix.version }} - - - name: Setup opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - run: | - opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} - opam install --deps-only --yes ./cerberus-lib.opam - - - name: Save cached opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - id: cache-opam-save - uses: actions/cache/save@v4 - with: - path: ~/.opam - key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + fail-on-cache-miss: true - name: Install Cerberus run: | diff --git a/.github/workflows/ci-pr-bench.yml.disabled b/.github/workflows/ci-pr-bench.yml.disabled index 921c7d774..534460f5d 100644 --- a/.github/workflows/ci-pr-bench.yml.disabled +++ b/.github/workflows/ci-pr-bench.yml.disabled @@ -45,28 +45,7 @@ jobs: with: path: ~/.opam key: ${{ matrix.version }} - - - name: Setup opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - run: | - opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} - opam install --deps-only --yes ./cerberus-lib.opam - opam switch create with_coq ${{ matrix.version }} - eval $(opam env --switch=with_coq) - opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released - opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git - opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git - opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git - opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - - - name: Save cached opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - id: cache-opam-save - uses: actions/cache/save@v4 - with: - path: ~/.opam - key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + fail-on-cache-miss: true - name: Install python dependencies run: pip install tabulate diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 481e5a1ee..93d535f5b 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -30,7 +30,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt install build-essential libgmp-dev z3 opam cmake + sudo apt-get install build-essential libgmp-dev z3 opam cmake - name: Restore cached opam id: cache-opam-restore @@ -44,6 +44,14 @@ jobs: run: | opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} opam install --deps-only --yes ./cerberus-lib.opam + opam switch create with_coq ${{ matrix.version }} + eval $(opam env --switch=with_coq) + opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released + opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git + opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git + opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad + opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git + opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - name: Save cached opam if: steps.cache-opam-restore.outputs.cache-hit != 'true' From 518be63be7166b721cbbe17aeb383cd300100a1f Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 12 Nov 2024 08:02:19 -0500 Subject: [PATCH 060/148] [CN-Test-Gen] Add BST delete to CI --- tests/cn-test-gen/src/bst.pass.c | 146 +++++++++++++++++++++++++++++++ 1 file changed, 146 insertions(+) diff --git a/tests/cn-test-gen/src/bst.pass.c b/tests/cn-test-gen/src/bst.pass.c index 63fe55450..8b67d436c 100644 --- a/tests/cn-test-gen/src/bst.pass.c +++ b/tests/cn-test-gen/src/bst.pass.c @@ -21,6 +21,10 @@ type_synonym VALUE = i64 type_synonym NodeData = { KEY key, VALUE value } function (KEY) defaultKey() { 0i32 } +function (VALUE) defaultValue() { 0i64 } +function (NodeData) defaultNodeData() { + { key: defaultKey(), value: defaultValue() } +} datatype ValueOption { ValueNone {}, @@ -116,6 +120,13 @@ function (boolean) hasRoot(KEY key, BST tree) { } } +function (boolean) isLeaf(BST tree) { + match tree { + Leaf {} => { true } + Node { data: _, smaller: _, larger: _ } => { false } + } +} + function [rec] (ValueOption) lookup(KEY key, BST tree) { match tree { Leaf {} => { ValueNone {} } @@ -407,3 +418,138 @@ ensures parent->smaller = new_node; } } + +/*@ +function [rec] ({ boolean empty, NodeData data, BST tree }) delLeast(BST root) { + match root { + Leaf {} => { { empty: true, data: defaultNodeData(), tree: Leaf {} } } + Node { data: data, smaller: smaller, larger: larger } => { + if (isLeaf(smaller)) { + { empty: false, data: data, tree: larger } + } else { + let res = delLeast(smaller); + { empty: false, + data: res.data, + tree: Node { data: data, smaller: res.tree, larger: larger } + } + } + } + } +} + +predicate (void) DeleteSmallest(pointer cur, NodeData data) { + if (is_null(cur)) { + assert(data == defaultNodeData()); + return; + } else { + take node = Owned(cur); + assert(node.key == data.key); + assert(node.value == data.value); + return; + } +} +@*/ + +struct MapNode* deleteSmallest(struct MapNode **root) +/*@ + requires + take root_ptr = Owned(root); + take tree = BST(root_ptr); + ensures + take new_root = Owned(root); + take new_tree = BST(new_root); + let res = delLeast(tree); + new_tree == res.tree; + take unused = DeleteSmallest(return, res.data); +@*/ +{ + struct MapNode *cur = *root; + if (!cur) return 0; + + struct MapNode *parent = 0; + while (cur->smaller) { + parent = cur; + cur = cur->smaller; + } + + if (parent) { + parent->smaller = cur->larger; + } + //! // + else { + *root = cur->larger; + } + //!! forget_to_update_root // + //! // + + return cur; +} + +/*@ +function [rec] (BST) delKey(KEY key, BST root) { + match root { + Leaf {} => { Leaf {} } + Node { data: data, smaller: smaller, larger: larger } => { + if (key == data.key) { + let res = delLeast(larger); + if (res.empty) { + smaller + } else { + Node { data: res.data, smaller: smaller, larger: res.tree } + } + } else { + //! // + if (key < data.key) { + Node { data: data, smaller: delKey(key, smaller), larger: larger } + } else { + Node { data: data, smaller: smaller, larger: delKey(key, larger) } + } + //!! delete_4_spec // + //! if (key < data.key) { delKey(key, smaller) } else { delKey(key, larger) } // + //!! delete_5_spec // + //! if (key > data.key) { Node { data: data, smaller: delKey(key, smaller), larger: larger } } else { Node { data: data, smaller: smaller, larger: delKey(key, larger) } } // + } + } + } +} +@*/ + +void deleteKey(struct MapNode **root, KEY key) +/*@ +requires + take root_ptr = Owned(root); + take tree = BST(root_ptr); +ensures + take new_ptr = Owned(root); + take new_tree = BST(new_ptr); + delKey(key, tree) == new_tree; +@*/ +{ + struct MapNode *found = *root; + struct MapNode *parent = findParent(&found, key); + + if (!found) { return; } + struct MapNode *remove = deleteSmallest(&found->larger); + if (remove) { + found->key = remove->key; + found->value = remove->value; + } else { + remove = found; + //! // + if (!parent) { + //!! always_update_root_instead_of_parent // + //! if (1) { // + *root = found->smaller; + //! // + } else if (key < parent->key) { + //!! always_assign_smaller // + //! } else if (1) { // + parent->smaller = found->smaller; + } else if (key > parent->key) { + parent->larger = found->smaller; + } else { + /* unreachable */ + } + } + cn_free_sized(remove, sizeof(struct MapNode)); +} From b528f5237bc77b036d378962131219aa9a74b268 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Wed, 13 Nov 2024 23:53:16 -0500 Subject: [PATCH 061/148] [CN-Test-Gen] Fix self-referencing constraints --- backend/cn/lib/testGeneration/genOptimize.ml | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 8d9bb4183..6f085aec8 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -3199,14 +3199,20 @@ module Specialization = struct let of_it (x : Sym.t) (it : IT.t) : t option = let (IT (it_, _, _)) = it in match it_ with - | Binop (LT, IT (Sym x', _, _), it') when Sym.equal x x' -> Some (of_max it') - | Binop (LE, IT (Sym x', x_bt, _), it') when Sym.equal x x' -> + | Binop (LT, IT (Sym x', _, _), it') + when Sym.equal x x' && not (SymSet.mem x (IT.free_vars it')) -> + Some (of_max it') + | Binop (LE, IT (Sym x', x_bt, _), it') + when Sym.equal x x' && not (SymSet.mem x (IT.free_vars it')) -> let loc = Locations.other __LOC__ in Some (of_max (IT.add_ (it', IT.num_lit_ Z.one x_bt loc) loc)) - | Binop (LT, it', IT (Sym x', x_bt, _)) when Sym.equal x x' -> + | Binop (LT, it', IT (Sym x', x_bt, _)) + when Sym.equal x x' && not (SymSet.mem x (IT.free_vars it')) -> let loc = Locations.other __LOC__ in Some (of_min (IT.sub_ (it', IT.num_lit_ Z.one x_bt loc) loc)) - | Binop (LE, it', IT (Sym x', _, _)) when Sym.equal x x' -> Some (of_min it') + | Binop (LE, it', IT (Sym x', _, _)) + when Sym.equal x x' && not (SymSet.mem x (IT.free_vars it')) -> + Some (of_min it') | _ -> None From 8260a5792bdd6ac37d96d9d3b35dee6ea3180656 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Sun, 17 Nov 2024 22:52:59 -0500 Subject: [PATCH 062/148] [CN-Test-Gen] More debugging info --- backend/cn/lib/testGeneration/genOptimize.ml | 83 ++++++++++++++++---- 1 file changed, 66 insertions(+), 17 deletions(-) diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 6f085aec8..d75eea537 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -1838,11 +1838,7 @@ module SplitConstraints = struct let (GT (gt_, _bt, loc)) = gt in match gt_ with | Assert (T (IT (Binop (Implies, it_if, it_then), _, loc_implies)), gt') -> - GT.pick_ - [ (Z.one, GT.assert_ (T (IT.not_ it_if loc_implies), gt') loc); - (Z.one, GT.assert_ (T it_then, gt') loc) - ] - loc_implies + GT.ite_ (it_if, GT.assert_ (T it_then, gt') loc, gt') loc_implies | _ -> gt in GT.map_gen_pre aux gt @@ -2148,9 +2144,10 @@ module RemoveUnused = struct let aux (gt : GT.t) : GT.t = let (GT (gt_, _, _)) = gt in match gt_ with - | Let (_, (x, gt1), gt2) - when GA.is_pure gt1 && not (SymSet.mem x (GT.free_vars gt2)) -> - gt2 + | Let (_, (x, gt_inner), gt_rest) + when GA.is_pure gt_inner && not (SymSet.mem x (GT.free_vars gt_rest)) -> + gt_rest + | Assert (T it, gt_rest) when IT.is_true it -> gt_rest | _ -> gt in GT.map_gen_post aux gt @@ -2734,7 +2731,37 @@ module ConstraintPropagation = struct ( EQ, IT (Const (Bits (_, m)), _, _), IT (Binop (Mod, IT (Sym x, x_bt, _), IT (Const (Bits (_, n)), _, _)), _, _) ) - when Z.equal m Z.zero -> + | Binop + ( EQ, + IT + ( Binop + ( Mod, + IT (Cast (_, IT (Sym x, x_bt, _)), _, _), + IT (Const (Bits (_, n)), _, _) ), + _, + _ ), + IT (Const (Bits (_, m)), _, _) ) + | Binop + ( EQ, + IT (Const (Bits (_, m)), _, _), + IT + ( Binop + ( Mod, + IT (Cast (_, IT (Sym x, x_bt, _)), _, _), + IT (Const (Bits (_, n)), _, _) ), + _, + _ ) ) + when Z.equal m Z.zero + && + let sgn, sz = + Option.get + (BT.is_bits_bt + (if BT.equal x_bt (Loc ()) then + Memory.uintptr_bt + else + x_bt)) + in + BT.fits_range (sgn, sz) n -> let@ bt_rep = IntRep.of_bt x_bt in Some (true, (x, Int (IntRep.intersect bt_rep (IntRep.of_mult n)))) | _ -> None @@ -3459,6 +3486,8 @@ module Specialization = struct end end +let debug msg = Cerb_debug.print_debug 2 [] (fun _ -> msg) + let all_passes (prog5 : unit Mucore.file) = [ PartialEvaluation.pass prog5 ] @ (if Config.has_pass "flatten" then [ PushPull.pass ] else []) @@ -3474,7 +3503,13 @@ let optimize_gen (prog5 : unit Mucore.file) (passes : StringSet.t) (gt : GT.t) : let passes = all_passes prog5 |> List.filter_map (fun { name; transform } -> - if StringSet.mem name passes then Some transform else None) + if StringSet.mem name passes then + Some + (fun gt -> + debug name; + transform gt) + else + None) in let opt (gt : GT.t) : GT.t = List.fold_left (fun gt pass -> pass gt) gt passes in let rec loop (fuel : int) (gt : GT.t) : GT.t = @@ -3501,18 +3536,32 @@ let optimize_gen_def (prog5 : unit Mucore.file) (passes : StringSet.t) (gd : GD. in gd |> aux - |> Fusion.Each.transform + |> (debug "fusion_each"; + Fusion.Each.transform) |> aux - |> (if Config.has_pass "picks" then FlipIfs.transform else fun gd' -> gd') + |> (if Config.has_pass "picks" then ( + debug "flip_ifs"; + FlipIfs.transform) + else + fun gd' -> gd') |> aux - |> (if Config.has_pass "reorder" then Reordering.transform [] else fun gd' -> gd') + |> (if Config.has_pass "reorder" then ( + debug "reorder"; + Reordering.transform []) + else + fun gd' -> gd') |> (if Config.has_pass "consistency" then fun gd' -> gd' - |> ConstraintPropagation.transform - |> Specialization.Equality.transform - |> Specialization.Integer.transform - |> Specialization.Pointer.transform + |> (debug "constraint_propagation"; + ConstraintPropagation.transform) + |> (debug "specialization_equality"; + Specialization.Equality.transform) + |> (debug "specialization_integer"; + Specialization.Integer.transform) + |> + (debug "specialization_pointer"; + Specialization.Pointer.transform) else fun gd' -> gd') |> InferAllocationSize.transform From 23f5921958db5b015c3936b42c0739b99a36fbdc Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Sun, 17 Nov 2024 23:11:37 -0500 Subject: [PATCH 063/148] [CN-Test-Gen] Generalize addresses in elaboration Already generalized in the runtime in #674 --- backend/cn/lib/testGeneration/genAnalysis.ml | 30 --- backend/cn/lib/testGeneration/genCodeGen.ml | 14 +- backend/cn/lib/testGeneration/genNormalize.ml | 160 +++++++++++++ .../cn/lib/testGeneration/genNormalize.mli | 4 + backend/cn/lib/testGeneration/genOptimize.ml | 219 +----------------- backend/cn/lib/testGeneration/genRuntime.ml | 86 +++---- backend/cn/lib/testGeneration/genRuntime.mli | 2 +- runtime/libcn/include/cn-testing/dsl.h | 17 +- 8 files changed, 231 insertions(+), 301 deletions(-) diff --git a/backend/cn/lib/testGeneration/genAnalysis.ml b/backend/cn/lib/testGeneration/genAnalysis.ml index 1ef576586..bb6d7389d 100644 --- a/backend/cn/lib/testGeneration/genAnalysis.ml +++ b/backend/cn/lib/testGeneration/genAnalysis.ml @@ -152,36 +152,6 @@ end let get_bounds = Bounds.get_bounds -let get_addr_offset_opt (it : IT.t) : (Sym.t * IT.t) option = - let (IT (it_, _, loc)) = it in - match it_ with - | ArrayShift { base = IT (Sym p_sym, _, _); ct; index = it_offset } -> - let it_offset = - if BT.equal (IT.bt it_offset) Memory.size_bt then - it_offset - else - IT.cast_ Memory.size_bt it_offset loc - in - Some (p_sym, IT.mul_ (IT.sizeOf_ ct loc, it_offset) loc) - | Binop (Add, IT (Sym p_sym, _, _), it_offset) -> - let it_offset = - if BT.equal (IT.bt it_offset) Memory.size_bt then - it_offset - else - IT.cast_ Memory.size_bt it_offset loc - in - Some (p_sym, it_offset) - | Sym p_sym -> Some (p_sym, IT.num_lit_ Z.zero Memory.size_bt loc) - | _ -> None - - -let get_addr_offset (it : IT.t) : Sym.t * IT.t = - match get_addr_offset_opt it with - | Some r -> r - | None -> - failwith ("unsupported format for address: " ^ CF.Pp_utils.to_plain_string (IT.pp it)) - - let get_recursive_preds (preds : (Sym.t * RP.definition) list) : SymSet.t = let get_calls (pred : RP.definition) : SymSet.t = pred.clauses diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index e9cea8c0c..b84ca2a69 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -211,16 +211,9 @@ let rec compile_term (path_vars |> GR.SymSet.to_seq |> List.of_seq |> List.map wrap_to_string) ]), mk_expr (AilEident x) ) - | Asgn { pointer; offset; sct; value; last_var; rest } -> + | Asgn { pointer; addr; sct; value; last_var; rest } -> let tmp_sym = Sym.fresh () in - let bt = BT.Bits (Unsigned, 64) in - let offset = - if BT.equal (IT.bt offset) bt then - offset - else - IT.cast_ bt offset (Locations.other __LOC__) - in - let b1, s1, e1 = compile_it sigma name offset in + let b1, s1, e1 = compile_it sigma name addr in let b2, s2, AnnotatedExpression (_, _, _, e2_) = compile_it sigma name value in let b3 = [ Utils.create_binding tmp_sym C.(mk_ctype_pointer no_qualifiers void) ] in let s3 = @@ -260,8 +253,7 @@ let rec compile_term ( None, [ (Locations.other __LOC__, [ Sym.pp_string x ]) ] )) ))) - (List.of_seq - (SymSet.to_seq (SymSet.add pointer (IT.free_vars offset)))) + (List.of_seq (SymSet.to_seq (IT.free_vars addr))) @ [ mk_expr (AilEconst ConstantNull) ] ))) ] in diff --git a/backend/cn/lib/testGeneration/genNormalize.ml b/backend/cn/lib/testGeneration/genNormalize.ml index 37a9648cf..a276346af 100644 --- a/backend/cn/lib/testGeneration/genNormalize.ml +++ b/backend/cn/lib/testGeneration/genNormalize.ml @@ -5,6 +5,166 @@ module GT = GenTerms module GD = GenDefinitions module SymMap = Map.Make (Sym) +module MemberIndirection = struct + type kind = + | Struct of Sym.t + | Record + + let rec replace_memberof_it + (k : kind) + (sym : Sym.t) + (dict : (Id.t * Sym.t) list) + (it : IT.t) + : IT.t + = + let repl = replace_memberof_it k sym dict in + let (IT (it_, bt, loc)) = it in + let it_ = + match it_ with + | Const _ | Sym _ | SizeOf _ | OffsetOf _ | Nil _ -> it_ + | Unop (op, it') -> IT.Unop (op, repl it') + | Binop (op, it1, it2) -> IT.Binop (op, repl it1, repl it2) + | ITE (it1, it2, it3) -> IT.ITE (repl it1, repl it2, repl it3) + | EachI ((min, (i_sym, i_bt), max), it') -> + IT.EachI ((min, (i_sym, i_bt), max), repl it') + | Tuple its -> IT.Tuple (List.map repl its) + | NthTuple (n, it') -> IT.NthTuple (n, repl it') + | Struct (tag, xits) -> IT.Struct (tag, List.map_snd repl xits) + | StructMember (it', x) -> + (match (k, IT.is_sym it') with + | Struct _tag, Some (y, _y_bt) when Sym.equal y sym -> + IT.Sym (List.assoc Id.equal x dict) + | _ -> IT.StructMember (repl it', x)) + | StructUpdate ((it_struct, x), it_val) -> + IT.StructUpdate ((repl it_struct, x), repl it_val) + | Record xits -> IT.Record (List.map_snd repl xits) + | RecordMember (it', x) -> + (match (k, IT.is_sym it') with + | Record, Some (y, _y_bt) when Sym.equal y sym -> + IT.Sym (List.assoc Id.equal x dict) + | _ -> IT.RecordMember (repl it', x)) + | RecordUpdate ((it_record, x), it_val) -> + IT.RecordUpdate ((repl it_record, x), repl it_val) + | Constructor (tag, xits) -> IT.Constructor (tag, List.map_snd repl xits) + | MemberShift (it', tag, member) -> IT.MemberShift (it', tag, member) + | ArrayShift { base; ct; index } -> + IT.ArrayShift { base = repl base; ct; index = repl index } + | CopyAllocId { addr; loc } -> IT.CopyAllocId { addr = repl addr; loc = repl loc } + | HasAllocId it' -> IT.HasAllocId (repl it') + | Cons (it1, it2) -> IT.Cons (repl it1, repl it2) + | Head it' -> IT.Head (repl it') + | Tail it' -> IT.Tail (repl it') + | NthList (it1, it2, it3) -> IT.NthList (repl it1, repl it2, repl it3) + | ArrayToList (it1, it2, it3) -> IT.ArrayToList (repl it1, repl it2, repl it3) + | Representable (sct, it') -> IT.Representable (sct, repl it') + | Good (sct, it') -> IT.Good (sct, repl it') + | Aligned { t; align } -> IT.Aligned { t = repl t; align = repl align } + | WrapI (sct, it') -> IT.WrapI (sct, repl it') + | MapConst (bt, it') -> IT.MapConst (bt, repl it') + | MapSet (it1, it2, it3) -> IT.MapSet (repl it1, repl it2, repl it3) + | MapGet (it1, it2) -> IT.MapGet (repl it1, repl it2) + | MapDef ((x, bt), it') -> IT.MapDef ((x, bt), repl it') + | Apply (fsym, its) -> IT.Apply (fsym, List.map repl its) + | Let ((x, it1), it2) -> IT.Let ((x, repl it1), it2) + | Match (it', pits) -> IT.Match (repl it', List.map_snd repl pits) + | Cast (bt, it') -> IT.Cast (bt, repl it') + in + IT (it_, bt, loc) + + + let replace_memberof_gt + (k : kind) + (sym : Sym.t) + (dict : (Id.t * Sym.t) list) + (gt : GT.t) + : GT.t + = + let repl = replace_memberof_it k sym dict in + let aux (gt : GT.t) : GT.t = + let (GT (gt_, bt, loc)) = gt in + let gt_ = + match gt_ with + | Alloc it -> GT.Alloc (repl it) + | Call (fsym, xits) -> GT.Call (fsym, List.map_snd repl xits) + | Asgn ((it_addr, sct), it_val, gt') -> + GT.Asgn ((repl it_addr, sct), repl it_val, gt') + | Return it -> GT.Return (repl it) + | Assert (T it, gt') -> GT.Assert (LC.T (repl it), gt') + | Assert (Forall ((i_sym, i_bt), it), gt') -> + GT.Assert (LC.Forall ((i_sym, i_bt), repl it), gt') + | ITE (it_if, gt_then, gt_else) -> GT.ITE (repl it_if, gt_then, gt_else) + | Map ((i_sym, i_bt, it_perm), gt_inner) -> + GT.Map ((i_sym, i_bt, repl it_perm), gt_inner) + | _ -> gt_ + in + GT (gt_, bt, loc) + in + GT.map_gen_pre aux gt + + + let transform (gt : GT.t) : GT.t = + let aux (gt : GT.t) : GT.t = + match gt with + | GT + ( Let + ( _backtracks, + (x, GT (Return (IT (Struct (_, xits), bt, loc_it)), _, loc_ret)), + gt' ), + _, + loc ) + | GT + ( Let + ( _backtracks, + (x, GT (Return (IT (Record xits, bt, loc_it)), _, loc_ret)), + gt' ), + _, + loc ) -> + let k = + match bt with + | Struct tag -> Struct tag + | Record _ -> Record + | _ -> failwith __LOC__ + in + let members_to_indirect, members_to_leave = + xits |> List.partition (fun (_, it) -> Option.is_none (IT.is_sym it)) + in + let indirect_map = + List.map_snd (fun _ -> Sym.fresh ()) members_to_indirect + @ List.map + (fun (y, it) -> (y, fst (Option.get (IT.is_sym it)))) + members_to_leave + in + let gt_main = + GT.let_ + ( 0, + ( x, + GT.return_ + (let members = + indirect_map + |> List.map (fun (y, z) -> + let it = List.assoc Id.equal y xits in + (y, IT.sym_ (z, IT.bt it, IT.loc it))) + in + match k with + | Struct tag -> IT.struct_ (tag, members) loc_it + | Record -> IT.record_ members loc_it) + loc_ret ), + replace_memberof_gt k x indirect_map gt' ) + loc + in + let here = Locations.other __LOC__ in + members_to_indirect + |> List.fold_left + (fun gt'' (y, it) -> + GT.let_ + (0, (List.assoc Id.equal y indirect_map, GT.return_ it here), gt'') + here) + gt_main + | _ -> gt + in + GT.map_gen_post aux gt +end + let rec arbitrary_of_sctype (sct : Sctypes.t) loc : GT.t = match sct with | Sctypes.Array (ct', Some len) -> diff --git a/backend/cn/lib/testGeneration/genNormalize.mli b/backend/cn/lib/testGeneration/genNormalize.mli index a6772a122..6323b3f35 100644 --- a/backend/cn/lib/testGeneration/genNormalize.mli +++ b/backend/cn/lib/testGeneration/genNormalize.mli @@ -1 +1,5 @@ +module MemberIndirection : sig + val transform : GenTerms.t -> GenTerms.t +end + val normalize : unit Mucore.file -> GenDefinitions.context -> GenDefinitions.context diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index d75eea537..dd6499fd3 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -1266,210 +1266,6 @@ module BranchPruning = struct let passes = [ Unused.pass; Inconsistent.pass ] end -module MemberIndirection = struct - type kind = - | Struct of Sym.t - | Record - - let rec replace_memberof_it - (k : kind) - (sym : Sym.t) - (dict : (Id.t * Sym.t) list) - (it : IT.t) - : IT.t - = - let repl = replace_memberof_it k sym dict in - let (IT (it_, bt, loc)) = it in - let it_ = - match it_ with - | Const _ | Sym _ | SizeOf _ | OffsetOf _ | Nil _ -> it_ - | Unop (op, it') -> IT.Unop (op, repl it') - | Binop (op, it1, it2) -> IT.Binop (op, repl it1, repl it2) - | ITE (it1, it2, it3) -> IT.ITE (repl it1, repl it2, repl it3) - | EachI ((min, (i_sym, i_bt), max), it') -> - IT.EachI ((min, (i_sym, i_bt), max), repl it') - | Tuple its -> IT.Tuple (List.map repl its) - | NthTuple (n, it') -> IT.NthTuple (n, repl it') - | Struct (tag, xits) -> IT.Struct (tag, List.map_snd repl xits) - | StructMember (it', x) -> - (match (k, IT.is_sym it') with - | Struct _tag, Some (y, _y_bt) when Sym.equal y sym -> - IT.Sym (List.assoc Id.equal x dict) - | _ -> IT.StructMember (repl it', x)) - | StructUpdate ((it_struct, x), it_val) -> - IT.StructUpdate ((repl it_struct, x), repl it_val) - | Record xits -> IT.Record (List.map_snd repl xits) - | RecordMember (it', x) -> - (match (k, IT.is_sym it') with - | Record, Some (y, _y_bt) when Sym.equal y sym -> - IT.Sym (List.assoc Id.equal x dict) - | _ -> IT.RecordMember (repl it', x)) - | RecordUpdate ((it_record, x), it_val) -> - IT.RecordUpdate ((repl it_record, x), repl it_val) - | Constructor (tag, xits) -> IT.Constructor (tag, List.map_snd repl xits) - | MemberShift (it', tag, member) -> IT.MemberShift (it', tag, member) - | ArrayShift { base; ct; index } -> - IT.ArrayShift { base = repl base; ct; index = repl index } - | CopyAllocId { addr; loc } -> IT.CopyAllocId { addr = repl addr; loc = repl loc } - | HasAllocId it' -> IT.HasAllocId (repl it') - | Cons (it1, it2) -> IT.Cons (repl it1, repl it2) - | Head it' -> IT.Head (repl it') - | Tail it' -> IT.Tail (repl it') - | NthList (it1, it2, it3) -> IT.NthList (repl it1, repl it2, repl it3) - | ArrayToList (it1, it2, it3) -> IT.ArrayToList (repl it1, repl it2, repl it3) - | Representable (sct, it') -> IT.Representable (sct, repl it') - | Good (sct, it') -> IT.Good (sct, repl it') - | Aligned { t; align } -> IT.Aligned { t = repl t; align = repl align } - | WrapI (sct, it') -> IT.WrapI (sct, repl it') - | MapConst (bt, it') -> IT.MapConst (bt, repl it') - | MapSet (it1, it2, it3) -> IT.MapSet (repl it1, repl it2, repl it3) - | MapGet (it1, it2) -> IT.MapGet (repl it1, repl it2) - | MapDef ((x, bt), it') -> IT.MapDef ((x, bt), repl it') - | Apply (fsym, its) -> IT.Apply (fsym, List.map repl its) - | Let ((x, it1), it2) -> IT.Let ((x, repl it1), it2) - | Match (it', pits) -> IT.Match (repl it', List.map_snd repl pits) - | Cast (bt, it') -> IT.Cast (bt, repl it') - in - IT (it_, bt, loc) - - - let replace_memberof_gt - (k : kind) - (sym : Sym.t) - (dict : (Id.t * Sym.t) list) - (gt : GT.t) - : GT.t - = - let repl = replace_memberof_it k sym dict in - let aux (gt : GT.t) : GT.t = - let (GT (gt_, bt, loc)) = gt in - let gt_ = - match gt_ with - | Alloc it -> GT.Alloc (repl it) - | Call (fsym, xits) -> GT.Call (fsym, List.map_snd repl xits) - | Asgn ((it_addr, sct), it_val, gt') -> - GT.Asgn ((repl it_addr, sct), repl it_val, gt') - | Return it -> GT.Return (repl it) - | Assert (T it, gt') -> GT.Assert (LC.T (repl it), gt') - | Assert (Forall ((i_sym, i_bt), it), gt') -> - GT.Assert (LC.Forall ((i_sym, i_bt), repl it), gt') - | ITE (it_if, gt_then, gt_else) -> GT.ITE (repl it_if, gt_then, gt_else) - | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.Map ((i_sym, i_bt, repl it_perm), gt_inner) - | _ -> gt_ - in - GT (gt_, bt, loc) - in - GT.map_gen_pre aux gt - - - let transform (gt : GT.t) : GT.t = - let aux (gt : GT.t) : GT.t = - match gt with - | GT - ( Let - ( _backtracks, - (x, GT (Return (IT (Struct (_, xits), bt, loc_it)), _, loc_ret)), - gt' ), - _, - loc ) - | GT - ( Let - ( _backtracks, - (x, GT (Return (IT (Record xits, bt, loc_it)), _, loc_ret)), - gt' ), - _, - loc ) -> - let k = - match bt with - | Struct tag -> Struct tag - | Record _ -> Record - | _ -> failwith __LOC__ - in - let members_to_indirect, members_to_leave = - xits |> List.partition (fun (_, it) -> Option.is_none (IT.is_sym it)) - in - let indirect_map = - List.map_snd (fun _ -> Sym.fresh ()) members_to_indirect - @ List.map - (fun (y, it) -> (y, fst (Option.get (IT.is_sym it)))) - members_to_leave - in - let gt_main = - GT.let_ - ( 0, - ( x, - GT.return_ - (let members = - indirect_map - |> List.map (fun (y, z) -> - let it = List.assoc Id.equal y xits in - (y, IT.sym_ (z, IT.bt it, IT.loc it))) - in - match k with - | Struct tag -> IT.struct_ (tag, members) loc_it - | Record -> IT.record_ members loc_it) - loc_ret ), - replace_memberof_gt k x indirect_map gt' ) - loc - in - let here = Locations.other __LOC__ in - members_to_indirect - |> List.fold_left - (fun gt'' (y, it) -> - GT.let_ - (0, (List.assoc Id.equal y indirect_map, GT.return_ it here), gt'') - here) - gt_main - | _ -> gt - in - GT.map_gen_post aux gt - - - let pass = { name = "member_indirection"; transform } -end - -(** This pass performs makes pointer offsets consistent *) -module PointerOffsets = struct - let transform (gt : GT.t) : GT.t = - let aux (gt : GT.t) : GT.t = - match gt with - | GT (Asgn ((it_addr, sct), it_val, gt'), _, loc) -> - let it_addr = - match it_addr with - | IT - ( Binop (Add, IT (ArrayShift { base; ct; index }, _, loc_shift), it_offset), - _, - loc_add ) -> - let index = - if BT.equal (IT.bt index) Memory.size_bt then - index - else - IT.cast_ Memory.size_bt index (Locations.other __LOC__) - in - IT.add_ - ( base, - IT.add_ - (IT.mul_ (index, IT.sizeOf_ ct loc_shift) loc_shift, it_offset) - loc_add ) - loc_shift - | IT - ( Binop - (Add, IT (Binop (Add, it_base, it_offset_1), _, loc_shift), it_offset_2), - _, - loc_add ) -> - IT.add_ (it_base, IT.add_ (it_offset_1, it_offset_2) loc_add) loc_shift - | _ -> it_addr - in - GT.asgn_ ((it_addr, sct), it_val, gt') loc - | _ -> gt - in - GT.map_gen_post aux gt - - - let pass = { name = "rewrite"; transform } -end - (** This pass performs various inlinings *) module Inline = struct (** This pass inlines generators that just return a constant or symbol *) @@ -1854,7 +1650,7 @@ end (** This pass infers how much allocation is needed for each pointer given the current intraprocedural context *) -module InferAllocationSize = struct +(* module InferAllocationSize = struct let name = "infer_alloc_size" let infer_size (vars : SymSet.t) (x : Sym.t) (gt : GT.t) : IT.t option = @@ -1941,7 +1737,7 @@ module InferAllocationSize = struct Some (aux (gd.iargs |> List.map fst |> SymSet.of_list) (Option.get gd.body)) in { gd with body } -end +end *) (** This pass uses [Simplify] to rewrite [IndexTerms.t] *) module TermSimplification = struct @@ -3491,10 +3287,9 @@ let debug msg = Cerb_debug.print_debug 2 [] (fun _ -> msg) let all_passes (prog5 : unit Mucore.file) = [ PartialEvaluation.pass prog5 ] @ (if Config.has_pass "flatten" then [ PushPull.pass ] else []) - @ [ MemberIndirection.pass ] @ Inline.passes @ RemoveUnused.passes - @ [ TermSimplification.pass prog5; TermSimplification'.pass; PointerOffsets.pass ] + @ [ TermSimplification.pass prog5; TermSimplification'.pass ] @ BranchPruning.passes @ if Config.has_pass "lift_constraints" then SplitConstraints.passes else [] @@ -3511,7 +3306,11 @@ let optimize_gen (prog5 : unit Mucore.file) (passes : StringSet.t) (gt : GT.t) : else None) in - let opt (gt : GT.t) : GT.t = List.fold_left (fun gt pass -> pass gt) gt passes in + let opt (gt : GT.t) : GT.t = + gt + |> List.fold_right (fun pass gt -> pass gt) passes + |> GenNormalize.MemberIndirection.transform + in let rec loop (fuel : int) (gt : GT.t) : GT.t = if fuel <= 0 then gt @@ -3564,7 +3363,7 @@ let optimize_gen_def (prog5 : unit Mucore.file) (passes : StringSet.t) (gd : GD. Specialization.Pointer.transform) else fun gd' -> gd') - |> InferAllocationSize.transform + (* |> InferAllocationSize.transform *) |> aux diff --git a/backend/cn/lib/testGeneration/genRuntime.ml b/backend/cn/lib/testGeneration/genRuntime.ml index 461eb328e..539080dd2 100644 --- a/backend/cn/lib/testGeneration/genRuntime.ml +++ b/backend/cn/lib/testGeneration/genRuntime.ml @@ -8,6 +8,7 @@ module GD = GenDefinitions module GBT = GenBaseTypes module GA = GenAnalysis module SymSet = Set.Make (Sym) +module SymMap = Map.Make (Sym) module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) module StringMap = Map.Make (String) @@ -37,7 +38,7 @@ type term = } | Asgn of { pointer : Sym.t; - offset : IT.t; + addr : IT.t; sct : Sctypes.t; value : IT.t; last_var : Sym.t; @@ -84,14 +85,8 @@ let rec free_vars_term (tm : term) : SymSet.t = | Alloc { bytes; sized = _ } -> IT.free_vars bytes | Call { fsym = _; iargs; oarg_bt = _; path_vars = _; sized = _ } -> SymSet.of_list (List.map snd iargs) - | Asgn { pointer; offset; sct = _; value; last_var = _; rest } -> - List.fold_left - SymSet.union - SymSet.empty - [ SymSet.singleton pointer; - IT.free_vars_list [ offset; value ]; - free_vars_term rest - ] + | Asgn { pointer = _; addr; sct = _; value; last_var = _; rest } -> + SymSet.union (IT.free_vars_list [ addr; value ]) (free_vars_term rest) | Let { backtracks = _; x; x_bt = _; value; last_var = _; rest } -> SymSet.union (free_vars_term value) (SymSet.remove x (free_vars_term rest)) | Return { value } -> IT.free_vars value @@ -162,32 +157,22 @@ let rec pp_term (tm : term) : Pp.document = (comma ^^ space) Sym.pp (path_vars |> SymSet.to_seq |> List.of_seq))) - | Asgn - { pointer : Sym.t; - offset : IT.t; - sct : Sctypes.t; - value : IT.t; - last_var : Sym.t; - rest : term - } -> + | Asgn { pointer; addr; sct; value; last_var; rest } -> Sctypes.pp sct ^^ space - ^^ Sym.pp pointer - ^^ space - ^^ plus - ^^ space - ^^ IT.pp offset + ^^ IT.pp addr ^^ space ^^ string ":=" ^^ space ^^ IT.pp value ^^ semi ^^ space - ^^ twice slash - ^^ space - ^^ string "backtracks to" - ^^ space - ^^ Sym.pp last_var + ^^ c_comment + (string "backtracks to" + ^^ space + ^^ Sym.pp last_var + ^^ string " allocs via " + ^^ Sym.pp pointer) ^^ break 1 ^^ pp_term rest | Let @@ -274,12 +259,12 @@ let nice_names (inputs : SymSet.t) (gt : GT.t) : GT.t = | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> (vars, gt) | Pick wgts -> let vars, wgts = - List.fold_left - (fun (vars', choices') (w, gr') -> + List.fold_right + (fun (w, gr') (vars', choices') -> let vars'', gr'' = aux vars' gr' in (vars'', (w, gr'') :: choices')) - (vars, []) wgts + (vars, []) in (vars, GT.pick_ wgts loc) | Asgn ((it_addr, sct), it_val, gt') -> @@ -392,16 +377,32 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = ([], fun _ gr -> gr) in gt_lets last_var (Call { fsym; iargs; oarg_bt = bt; path_vars; sized = None }) - | Asgn ((it_addr, sct), value, rest) -> - let pointer, offset = GA.get_addr_offset it_addr in - if not (SymSet.mem pointer inputs || List.exists (Sym.equal pointer) vars) then - failwith - (Sym.pp_string pointer - ^ " not in [" - ^ String.concat "; " (List.map Sym.pp_string vars) - ^ "] from " - ^ Pp.plain (Locations.pp (IT.loc it_addr))); - Asgn { pointer; offset; sct; value; last_var; rest = aux vars path_vars rest } + | Asgn ((addr, sct), value, rest) -> + let pointer = + let pointers = + let free_vars = IT.free_vars_bts addr in + if SymMap.cardinal free_vars == 1 then + free_vars + else + free_vars |> SymMap.filter (fun _ bt -> BT.equal bt (BT.Loc ())) + in + if not (SymMap.cardinal pointers == 1) then + Cerb_debug.print_debug 2 [] (fun () -> + Pp.( + plain + (braces + (separate_map + (comma ^^ space) + Sym.pp + (List.map fst (SymMap.bindings pointers))) + ^^ space + ^^ string " in " + ^^ IT.pp addr))); + List.find + (fun x -> SymMap.mem x pointers) + (vars @ List.of_seq (SymSet.to_seq inputs)) + in + Asgn { pointer; addr; sct; value; last_var; rest = aux vars path_vars rest } | Let (backtracks, (x, gt1), gt2) -> Let { backtracks; @@ -473,7 +474,10 @@ let elaborate_gd ({ filename; recursive; spec = _; name; iargs; oargs; body } : name; iargs = List.map_snd GBT.bt iargs; oargs = List.map_snd GBT.bt oargs; - body = elaborate_gt (SymSet.of_list (List.map fst iargs)) (Option.get body) + body = + Option.get body + |> GenNormalize.MemberIndirection.transform + |> elaborate_gt (SymSet.of_list (List.map fst iargs)) } diff --git a/backend/cn/lib/testGeneration/genRuntime.mli b/backend/cn/lib/testGeneration/genRuntime.mli index a81960aa8..d5269cde3 100644 --- a/backend/cn/lib/testGeneration/genRuntime.mli +++ b/backend/cn/lib/testGeneration/genRuntime.mli @@ -31,7 +31,7 @@ type term = } | Asgn of { pointer : Sym.t; - offset : IT.t; + addr : IT.t; sct : Sctypes.t; value : IT.t; last_var : Sym.t; diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index a02ddabd6..4c98ef901 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -88,18 +88,19 @@ cn_gen_backtrack_relevant_add_many(toAdd); \ } -#define CN_GEN_ASSIGN(p, offset, addr_ty, value, tmp, gen_name, last_var, ...) \ - if (convert_from_cn_pointer(p) == 0) { \ - cn_gen_backtrack_relevant_add((char*)#p); \ +#define CN_GEN_ASSIGN(pointer, addr, addr_ty, value, tmp, gen_name, last_var, ...) \ + if (convert_from_cn_pointer(pointer) == 0) { \ + cn_gen_backtrack_relevant_add((char*)#pointer); \ cn_gen_backtrack_alloc_set(8); \ goto cn_label_##last_var##_backtrack; \ } \ - void *tmp##_ptr = convert_from_cn_pointer(cn_pointer_add_cn_bits_u64(p, offset)); \ + void* tmp##_ptr = convert_from_cn_pointer(addr); \ if (!cn_gen_alloc_check(tmp##_ptr, sizeof(addr_ty))) { \ - cn_gen_backtrack_relevant_add((char*)#p); \ - cn_bits_u64* tmp##_size = cn_bits_u64_add( \ - offset, \ - convert_to_cn_bits_u64(sizeof(addr_ty))); \ + cn_gen_backtrack_relevant_add((char*)#pointer); \ + cn_bits_u64* tmp##_size = convert_to_cn_bits_u64( \ + (uintptr_t)tmp##_ptr \ + + sizeof(addr_ty) \ + - (uintptr_t)convert_from_cn_pointer(pointer)); \ cn_gen_backtrack_alloc_set(convert_from_cn_bits_u64(tmp##_size)); \ goto cn_label_##last_var##_backtrack; \ } \ From 2ea7a65f0b47609d01ec853aac2046c6f04b15e9 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 18 Nov 2024 13:47:27 -0500 Subject: [PATCH 064/148] [CN-Test-Gen] More pointer specialization --- backend/cn/lib/testGeneration/genOptimize.ml | 41 +++++++++++++------- 1 file changed, 28 insertions(+), 13 deletions(-) diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index dd6499fd3..f77129d7e 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -2568,8 +2568,17 @@ module ConstraintPropagation = struct let is_const (Int r) = IntRep.is_const r let to_stmts (x : Sym.t) (bt : BT.t) (Int r : t) : GS.t list = + let loc = Locations.other __LOC__ in + let lit n = + if BT.equal bt (Loc ()) then + IT.pointer_ ~alloc_id:Z.zero ~addr:n loc + else + IT.num_lit_ n bt loc + in + let le (n, m) = + if BT.equal bt (Loc ()) then IT.lePointer_ (n, m) loc else IT.le_ (n, m) loc + in let aux (sgn : BT.sign) (sz : int) : GS.t list = - let loc = Locations.other __LOC__ in let min_bt, max_bt = BT.bits_range (sgn, sz) in if IntRep.is_empty r then [ GS.Assert (T (IT.bool_ false loc)) ] @@ -2577,22 +2586,17 @@ module ConstraintPropagation = struct let min, max = (Option.get (IntRep.minimum r), Option.get (IntRep.maximum r)) in let stmts_range = if Z.equal min max then - [ GS.Assert (T (IT.eq_ (IT.sym_ (x, bt, loc), IT.num_lit_ min bt loc) loc)) - ] + [ GS.Assert (T (IT.eq_ (IT.sym_ (x, bt, loc), lit min) loc)) ] else ( let stmt_min = if Z.lt min_bt min then - [ GS.Assert - (LC.T (IT.le_ (IT.num_lit_ min bt loc, IT.sym_ (x, bt, loc)) loc)) - ] + [ GS.Assert (LC.T (le (lit min, IT.sym_ (x, bt, loc)))) ] else [] in let stmt_max = if Z.lt max max_bt then - [ GS.Assert - (LC.T (IT.le_ (IT.sym_ (x, bt, loc), IT.num_lit_ max bt loc) loc)) - ] + [ GS.Assert (LC.T (le (IT.sym_ (x, bt, loc), lit max))) ] else [] in @@ -2605,8 +2609,17 @@ module ConstraintPropagation = struct [ GS.Assert (LC.T (IT.eq_ - ( IT.mod_ (IT.sym_ (x, bt, loc), IT.num_lit_ r.mult bt loc) loc, - IT.num_lit_ Z.zero bt loc ) + ( IT.mod_ + (if BT.equal bt (Loc ()) then + ( IT.cast_ Memory.uintptr_bt (IT.sym_ (x, bt, loc)) loc, + IT.num_lit_ r.mult Memory.uintptr_bt loc ) + else + (IT.sym_ (x, bt, loc), lit r.mult)) + loc, + IT.num_lit_ + Z.zero + (if BT.equal bt (Loc ()) then Memory.uintptr_bt else bt) + loc ) loc)) ] in @@ -3090,7 +3103,7 @@ module Specialization = struct (stmt :: stmts', v) | [] -> (match bt with - | Bits _ -> ([], { mult = None; min = None; max = None }) + | Bits _ | Loc _ -> ([], { mult = None; min = None; max = None }) | _ -> failwith __LOC__) in aux stmts @@ -3157,7 +3170,9 @@ module Specialization = struct | Let (backtracks, (x, gt)) :: stmts' -> let vars = SymSet.add x vars in let stmts', (gt, stmts'') = - if Option.is_some (BT.is_bits_bt (GT.bt gt)) then ( + if + BT.equal (GT.bt gt) (BT.Loc ()) || Option.is_some (BT.is_bits_bt (GT.bt gt)) + then ( let stmts', v = collect_constraints vars x (GT.bt gt) stmts' in (stmts', compile_constraints x v gt)) else From ac768bd47a61d0175ad89a940455d385aee3ba0f Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 19 Nov 2024 14:39:01 +0000 Subject: [PATCH 065/148] CN: record additional loop location information for loops in mucore (#718) --- backend/cn/lib/core_to_mucore.ml | 6 +++--- backend/cn/lib/executable_spec_extract.ml | 3 ++- backend/cn/lib/mucore.ml | 3 ++- backend/cn/lib/mucore.mli | 3 ++- frontend/model/annot.lem | 9 ++++++++- frontend/model/cabs_to_ail.lem | 8 ++++---- frontend/model/cabs_to_ail_effect.lem | 13 ++++++++++--- 7 files changed, 31 insertions(+), 14 deletions(-) diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 4bc21a128..2c3836685 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -1128,7 +1128,7 @@ let normalise_label fsym (markers_env, precondition_cn_desugaring_state) (global_types, visible_objects_env) - (accesses, loop_attributes) + (accesses, (loop_attributes : CF.Annot.loop_attributes)) (env : C.env) st _label_name @@ -1141,7 +1141,7 @@ let normalise_label | Some (LAloop loop_id) -> let@ desugared_inv, cn_desugaring_state, loop_condition_loc = match Pmap.lookup loop_id loop_attributes with - | Some (marker_id, attrs, loop_condition_loc) -> + | Some { marker_id; attributes = attrs; loc_condition; loc_loop } -> let@ inv = Parse.loop_spec attrs in let d_st = CAE. @@ -1153,7 +1153,7 @@ let normalise_label } in let@ inv, d_st = desugar_conds d_st inv in - return (inv, d_st.inner.cn_state, loop_condition_loc) + return (inv, d_st.inner.cn_state, (loc_condition, loc_loop)) | None -> assert false (* return ([], precondition_cn_desugaring_state) *) in diff --git a/backend/cn/lib/executable_spec_extract.ml b/backend/cn/lib/executable_spec_extract.ml index 3474d693f..f038e56bc 100644 --- a/backend/cn/lib/executable_spec_extract.ml +++ b/backend/cn/lib/executable_spec_extract.ml @@ -106,7 +106,8 @@ let rec stmts_in_expr (Mucore.Expr (loc, _, _, e_)) = let from_loop ((_label_sym : Sym.t), (label_def : _ label_def)) : loop option = match label_def with | Return _ -> None - | Label (_loc, label_args_and_body, _annots, _, `Loop loop_condition_loc) -> + | Label (_loc, label_args_and_body, _annots, _, `Loop (loop_condition_loc, _loop_loc)) + -> let label_args_and_body = Core_to_mucore.at_of_arguments Fun.id label_args_and_body in let label_args_and_statements = ArgumentTypes.map stmts_in_expr label_args_and_body in Some (loop_condition_loc, label_args_and_statements) diff --git a/backend/cn/lib/mucore.ml b/backend/cn/lib/mucore.ml index 43cf4a3a3..f83dd86cc 100644 --- a/backend/cn/lib/mucore.ml +++ b/backend/cn/lib/mucore.ml @@ -380,7 +380,8 @@ type 'TY label_def = * 'TY expr arguments * Cerb_frontend.Annot.annot list * parse_ast_label_spec - * [ `Loop of Locations.t ] + * [ `Loop of Locations.t * Locations.t ] +(*first loc is condition, second is whole loop*) (*loop condition location, for executable checking *) type trusted = diff --git a/backend/cn/lib/mucore.mli b/backend/cn/lib/mucore.mli index 6a247aa8a..c8567b750 100644 --- a/backend/cn/lib/mucore.mli +++ b/backend/cn/lib/mucore.mli @@ -283,7 +283,8 @@ type 'TY label_def = * 'TY expr arguments * Cerb_frontend.Annot.annot list * parse_ast_label_spec - * [ `Loop of Locations.t ] + * [ `Loop of Locations.t * Locations.t ] +(*first loc is condition, second is whole loop*) (*loop condition location, for executable checking *) type trusted = diff --git a/frontend/model/annot.lem b/frontend/model/annot.lem index 0314fa44d..84993e78b 100644 --- a/frontend/model/annot.lem +++ b/frontend/model/annot.lem @@ -89,7 +89,14 @@ type identifier_item_kind = type identifier_env = map Symbol.identifier (maybe (identifier_item_kind * Symbol.sym)) -type loop_attributes = map loop_id (nat * attributes * Loc.t) (* nat is marker id, loc is location of loop condition *) +type loop_attribute = + <| marker_id : nat; + attributes : attributes; + loc_condition : Loc.t; + loc_loop : Loc.t; |> + +type loop_attributes = map loop_id loop_attribute +(*type loop_attributes = map loop_id (nat * attributes * Loc.t * Loc.t)*) (* nat is marker id, first loc is location of loop condition, second loc is location of whole loop *) val get_loc: list annot -> maybe Loc.t let rec get_loc annots = diff --git a/frontend/model/cabs_to_ail.lem b/frontend/model/cabs_to_ail.lem index 114260456..8907f3cdf 100644 --- a/frontend/model/cabs_to_ail.lem +++ b/frontend/model/cabs_to_ail.lem @@ -3716,7 +3716,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.return (d_e, d_s) end >>= fun (d_e, d_s) -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs (Loc.locOf e) >>= fun () -> + E.record_loop_attribute loop_id attrs (Loc.locOf e) loc >>= fun () -> if has_continue s then (* while (E) S ==> while (E) { S; cont: ;} *) E.return begin @@ -3748,7 +3748,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.return (d_e, d_s) end >>= fun (d_e, d_s) -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs (Loc.locOf e) >>= fun () -> + E.record_loop_attribute loop_id attrs (Loc.locOf e) loc >>= fun () -> if has_continue s then (* do S (E) ==> do { S; cont: ;} (E) *) E.return begin @@ -3779,7 +3779,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = desugar_init_declarator attrs isAtomic (specifs.alignment_specifiers <> []) base_qs base_ty specifs.storage_classes init ) idecltors >>= fun xs -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs_outer (match e2_opt with Just e2 -> Loc.locOf e2 | Nothing -> Loc.unknown end) >> + E.record_loop_attribute loop_id attrs_outer (match e2_opt with Just e2 -> Loc.locOf e2 | Nothing -> Loc.unknown end) loc >> (* for each [init_declarator] *) E.foldrM (fun opt (acc1, acc2) -> match opt with @@ -3876,7 +3876,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.register_label cont_ident >> E.resolve_label cont_ident >>= fun cont_sym -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs (match e2_opt with Just e2 -> Loc.locOf e2 | Nothing -> Loc.unknown end) >> + E.record_loop_attribute loop_id attrs (match e2_opt with Just e2 -> Loc.locOf e2 | Nothing -> Loc.unknown end) loc >> let ctx' = <| cont_ident_opt= Just cont_ident |> in diff --git a/frontend/model/cabs_to_ail_effect.lem b/frontend/model/cabs_to_ail_effect.lem index 3bd9d292d..676b15dc3 100644 --- a/frontend/model/cabs_to_ail_effect.lem +++ b/frontend/model/cabs_to_ail_effect.lem @@ -1302,11 +1302,18 @@ let register_cn_datatype magic_loc ident loc mk_cases = -val record_loop_attribute: Annot.loop_id -> Annot.attributes -> Loc.t -> desugM unit -let record_loop_attribute id attr loc = +val record_loop_attribute: Annot.loop_id -> Annot.attributes -> Loc.t -> Loc.t -> desugM unit +let record_loop_attribute id attr loc_condition loc_loop = record_marker () >>= fun marker_id -> get_inner >>= fun st -> - put_inner <|st with loop_attributes = (Map.insert id (marker_id, attr, loc) st.loop_attributes) |> + let loop_attribute = + <| Annot.marker_id = marker_id; + Annot.attributes = attr; + Annot.loc_condition = loc_condition; + Annot.loc_loop = loc_loop; + |> + in + put_inner <|st with loop_attributes = (Map.insert id loop_attribute st.loop_attributes) |> val get_loop_attributes: unit -> desugM Annot.loop_attributes let get_loop_attributes () = From 21ec7e041e8d2ca77b9d4661b1f5d844c07e311b Mon Sep 17 00:00:00 2001 From: Michal Podhradsky Date: Thu, 21 Nov 2024 00:20:49 -0800 Subject: [PATCH 066/148] Fix z3 install and CN tests for Dockerfiles (#712) * Add GPG key import to the Redhat build to avoid package signature errors * Fix the docker test script, and update z3 installation * Run docker actions any time a dockerfile is changed * Specify the working directory for the container * Minimal dockerfile change (added documentation) to test triggering the docker action * Trigger docker action on any push event that also changes a Dockerfile. This should be OK as we don't expect the dockerfiles to be changing very often and from multiple branches * Also enable docker action run any time there is a change in the docker.yml file * Change the path hoping to trigger the docker action * Try disabling the scheduled run * Re-enabling the scheduled run * Try triggering docker.yml on PR * Disable Docker push on PRs It's not allowed anyway (as desired) but it fails the CI spuriously. * Fix Docker push condition * Fix other Docker push condition * Update test-docker image dependencies --------- Co-authored-by: Dhruv Makwana --- .github/workflows/docker.yml | 13 ++++++++++--- Dockerfile.redhat | 13 +++---------- Dockerfile.ubuntu | 3 ++- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index d706c6f08..6104a323e 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -1,8 +1,14 @@ name: docker on: + # Run this action every day schedule: - cron: '30 18 * * *' + # Run this action any time any dockerfile changes + pull_request: + paths: + - 'Dockerfile.**' + - '**docker.yml' env: CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn @@ -44,7 +50,7 @@ jobs: with: context: . platforms: linux/amd64,linux/arm64 - push: true + push: ${{ github.event_name != 'pull_request' }} tags: ${{env.CERBERUS_IMAGE_ID}}:release file: Dockerfile.ubuntu github-token: ${{ secrets.GITHUB_TOKEN }} @@ -76,7 +82,7 @@ jobs: with: context: . platforms: linux/amd64,linux/arm64 - push: true + push: ${{ github.event_name != 'pull_request' }} tags: ${{env.CERBERUS_IMAGE_ID}}:release-redhat file: Dockerfile.redhat attests: type=sbom @@ -85,6 +91,7 @@ jobs: test-docker-images: runs-on: ubuntu-latest + needs: [docker-release-redhat, docker-release-ubuntu] strategy: matrix: tag: [release, release-redhat] @@ -94,4 +101,4 @@ jobs: - name: Run CN CI tests run: | docker pull ${{env.CERBERUS_IMAGE_ID}}:${{ matrix.tag }} - docker run -v $PWD:/work ${{env.CERBERUS_IMAGE_ID}}:${{ matrix.tag }} tests/run-cn.sh + docker run -v $PWD:/work -w /work ${{env.CERBERUS_IMAGE_ID}}:${{ matrix.tag }} bash tests/run-cn.sh diff --git a/Dockerfile.redhat b/Dockerfile.redhat index f7101cbb1..b0dd7b231 100644 --- a/Dockerfile.redhat +++ b/Dockerfile.redhat @@ -1,21 +1,13 @@ +# Build a minimal cerberus release image FROM redhat/ubi9:9.4 -# Install basic dependencies +# Install system packages RUN yum update -y && \ yum install -y xz sudo gcc unzip \ diffutils patch pkgconfig bzip2 \ git perl wget ca-certificates \ mpfr-devel gmp-devel m4 -# Install additional FEDORA packages -# from https://www.cyberciti.biz/faq/install-epel-repo-on-an-rhel-8-x/ -# Currently the FEDORA packages are needed only for Z3 -# NOTE: we might have to eventually use *only* RedHat packages -# which would mean installing Z3 directly from the release page -RUN yum install -y https://dl.fedoraproject.org/pub/epel/epel-release-latest-9.noarch.rpm && \ - yum update -y && \ - yum install -y z3 - # Install OPAM # See https://opam.ocaml.org/doc/1.2/Install.html RUN curl -fsSL https://opam.ocaml.org/install.sh | sh @@ -26,6 +18,7 @@ RUN opam init --disable-sandboxing ADD . /opt/cerberus WORKDIR /opt/cerberus RUN opam install --deps-only ./cerberus-lib.opam ./cn.opam +RUN opam install z3 RUN eval `opam env` \ && make install_cn diff --git a/Dockerfile.ubuntu b/Dockerfile.ubuntu index 26657ef57..96d1e8900 100644 --- a/Dockerfile.ubuntu +++ b/Dockerfile.ubuntu @@ -1,6 +1,7 @@ -# Build a minimal release image +# Build a minimal cerberus release image FROM ubuntu:22.04 +# Install system packages RUN apt-get update RUN apt-get upgrade -y RUN apt-get install -y opam libgmp-dev libmpfr-dev From 4cc6b59a7c171a4c0aec9955b5d15c06475679f5 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Thu, 21 Nov 2024 08:24:41 +0000 Subject: [PATCH 067/148] CN: Parallelise and caputure output in CN CI (#703) * CN: Add Python for running CN tests This allows us to parallelise some of the testing easily, and also use diff-based tests rather than just relying on return codes. * CN: Switch to Python script and diffs The docker CI uses run-cn.sh so keeping it for now. * CN: Tidy up lemmma CI Not enabling it just yet because (a) it's not under active development and (b) I want to sort out caching first so that rebuilding Cerberus and opam don't eat up any savings from parallelising. * Generalise test script The test script now requires a (JSON) config file with documented attributes, and does not default to a test directory or executable. It also includes a `--dry-run` flag to see what command is being run. * CN: Use Python for running CN VIP tests * Swap order of args in diff-prog --- .github/workflows/ci-cn-spec-testing.yml | 2 +- .github/workflows/ci-cn.yml | 14 +-- .github/workflows/ci-pr-bench.yml.disabled | 4 +- tests/cn/alloc_create.c.verify | 2 + tests/cn/alloc_token.c.verify | 1 + tests/cn/and_or_precedence.error.c.verify | 9 ++ tests/cn/append.c.verify | 3 + tests/cn/arith_type.error.c.verify | 8 ++ tests/cn/arrow_access.c.verify | 3 + tests/cn/assert_on_toplevel.error.c.verify | 5 + tests/cn/b_or.c.verify | 2 + tests/cn/b_xor.c.verify | 2 + tests/cn/bad_col.error.c.verify | 5 + tests/cn/bad_constructor_user.error.c.verify | 8 ++ tests/cn/bad_function_call.error.c.verify | 8 ++ tests/cn/bad_record.error.c.verify | 4 + tests/cn/bad_record2.error.c.verify | 4 + tests/cn/bad_recursion.error.c.verify | 6 + tests/cn/bad_resource_var.error.c.verify | 9 ++ tests/cn/before_from_bytes.error.c.verify | 13 +++ tests/cn/before_to_bytes.error.c.verify | 7 ++ tests/cn/bitwise_and.c.verify | 2 + tests/cn/bitwise_and_type_left.error.c.verify | 5 + .../cn/bitwise_and_type_right.error.c.verify | 8 ++ tests/cn/bitwise_compl.c.verify | 2 + tests/cn/bitwise_compl_precedence.c.verify | 2 + tests/cn/bitwise_compl_type.error.c.verify | 5 + tests/cn/block_type.c.verify | 3 + tests/cn/builtin_ctz.c.verify | 2 + tests/cn/builtin_ctz_val.c.verify | 2 + tests/cn/cn_inline.c.verify | 6 + ...cnfunction_mismatched_args1.error.c.verify | 7 ++ ...cnfunction_mismatched_args2.error.c.verify | 7 ++ ...cnfunction_mismatched_args3.error.c.verify | 7 ++ ...cnfunction_mismatched_args4.error.c.verify | 8 ++ tests/cn/copy_alloc_id.c.verify | 4 + tests/cn/copy_alloc_id.error.c.verify | 8 ++ tests/cn/copy_alloc_id2.error.c.verify | 8 ++ tests/cn/create_rdonly.c.verify | 2 + tests/cn/disj_nonnull.c.verify | 3 + tests/cn/division.c.verify | 2 + tests/cn/division_by_0.error.c.verify | 7 ++ tests/cn/division_casting.c.verify | 2 + tests/cn/division_precedence.c.verify | 4 + tests/cn/division_return_sign.error.c.verify | 8 ++ tests/cn/division_return_size.error.c.verify | 7 ++ tests/cn/division_with_constants.c.verify | 4 + tests/cn/doubling.c.verify | 3 + .../cn/duplicate_datatype_var.error.c.verify | 4 + tests/cn/duplicate_pattern_var.error.c.verify | 4 + tests/cn/enum_and_and.c.verify | 2 + tests/cn/extract_verbose.c.verify | 23 ++++ tests/cn/failing_postcond.error.c.verify | 9 ++ tests/cn/failing_precond.error.c.verify | 8 ++ tests/cn/forloop_with_decl.c.verify | 2 + tests/cn/from_bytes.error.c.verify | 11 ++ tests/cn/fun_addrs_cn_stmt.c.verify | 3 + tests/cn/fun_ptr_extern.c.verify | 5 + tests/cn/fun_ptr_known.c.verify | 5 + tests/cn/fun_ptr_three_opts.c.verify | 7 ++ tests/cn/get_from_arr.c.verify | 14 +++ tests/cn/get_from_array.c.verify | 15 +++ .../cn/ghost_pointer_to_bitvec_cast.c.verify | 3 + tests/cn/gnu_case_ranges.c.verify | 3 + tests/cn/gnu_choose.c.verify | 4 + tests/cn/gnu_ctz.c.verify | 3 + tests/cn/gnu_ffs.c.verify | 3 + tests/cn/gnu_types_compatible.c.verify | 4 + tests/cn/has_alloc_id.c.verify | 4 + tests/cn/has_alloc_id.error.c.verify | 8 ++ tests/cn/has_alloc_id_ptr_eq.error.c.verify | 9 ++ tests/cn/has_alloc_id_ptr_eq2.error.c.verify | 9 ++ tests/cn/has_alloc_id_ptr_neq.c.verify | 3 + tests/cn/has_alloc_id_ptr_neq.error.c.verify | 9 ++ tests/cn/has_alloc_id_shift.c.verify | 4 + tests/cn/implies.c.verify | 2 + tests/cn/implies2.error.c.verify | 9 ++ tests/cn/implies3.error.c.verify | 5 + tests/cn/implies_associativity.c.verify | 2 + tests/cn/implies_precedence.c.verify | 2 + tests/cn/incomplete_match.error.c.verify | 4 + tests/cn/inconsistent.error.c.verify | 5 + tests/cn/inconsistent2.error.c.verify | 8 ++ tests/cn/inconsistent3.error.c.verify | 5 + tests/cn/increments.c.verify | 3 + tests/cn/int_to_ptr.c.verify | 3 + tests/cn/int_to_ptr.error.c.verify | 8 ++ tests/cn/left_shift_const.c.verify | 3 + tests/cn/lexer_hack_parse.error.c.verify | 5 + tests/cn/list_literal_type.error.c.verify | 5 + tests/cn/list_rev01.c.verify | 2 + tests/cn/magic_comment_not_closed.c.verify | 5 + tests/cn/map_set.error.c.verify | 4 + tests/cn/mask_ptr.c.verify | 3 + tests/cn/match.c.verify | 3 + tests/cn/max_min_consts.c.verify | 3 + tests/cn/max_pipes.error.c.verify | 45 +++++++ tests/cn/memcpy.c.verify | 32 +++++ tests/cn/mergesort.c.verify | 5 + tests/cn/mergesort_alt.c.verify | 5 + tests/cn/merging_arrays.error.c.verify | 11 ++ tests/cn/missing_resource.error.c.verify | 8 ++ .../missing_resource_indirect.error.c.verify | 10 ++ tests/cn/mod.c.verify | 2 + tests/cn/mod_by_0.error.c.verify | 7 ++ tests/cn/mod_casting.c.verify | 2 + tests/cn/mod_precedence.c.verify | 4 + tests/cn/mod_return_sign.error.c.verify | 8 ++ tests/cn/mod_return_size.error.c.verify | 9 ++ tests/cn/mod_with_constants.c.verify | 4 + tests/cn/multifile/f.c.verify | 3 + tests/cn/multifile/g.c.verify | 2 + tests/cn/mutual_rec/build.sh | 6 - tests/cn/mutual_rec/coq_lemmas/Makefile | 6 +- tests/cn/mutual_rec/coq_lemmas/_CoqProject | 3 - tests/cn/mutual_rec/mutual_rec1.c.verify | 3 + tests/cn/mutual_rec/mutual_rec2.c.verify | 10 ++ tests/cn/mutual_rec/mutual_rec3.c.verify | 2 + tests/cn/null_to_int.c.verify | 3 + tests/cn/ownership_at_negative_index.c.verify | 11 ++ tests/cn/partial_init_bytes.error.c.verify | 16 +++ tests/cn/pointer_to_char_cast.c.verify | 3 + tests/cn/pointer_to_char_cast.error.c.verify | 8 ++ tests/cn/pointer_to_int_cast.error.c.verify | 7 ++ tests/cn/pointer_to_intptr_t_cast.c.verify | 3 + tests/cn/pointer_to_uintptr_t_cast.c.verify | 3 + ...ointer_to_unsigned_int_cast.error.c.verify | 8 ++ tests/cn/pred_def01.c.verify | 2 + tests/cn/pred_def02.c.verify | 2 + tests/cn/pred_def03.error.c.verify | 5 + tests/cn/pred_def04.c.verify | 2 + ...viously_inconsistent_assumptions1.c.verify | 1 + ...viously_inconsistent_assumptions2.c.verify | 2 + tests/cn/ptr_diff.c.verify | 6 + tests/cn/ptr_diff.error.c.verify | 8 ++ tests/cn/ptr_diff2.c.verify | 3 + tests/cn/ptr_diff2.error.c.verify | 8 ++ tests/cn/ptr_relop.c.verify | 6 + tests/cn/ptr_relop.error.c.verify | 8 ++ tests/cn/record1.c.verify | 11 ++ tests/cn/redundant_pattern.error.c.verify | 8 ++ tests/cn/reverse.c.verify | 2 + tests/cn/reverse.error.c.verify | 17 +++ tests/cn/shift_diff_sz.c.verify | 3 + tests/cn/simple_loop.c.verify | 3 + tests/cn/simplify_add_0.c.verify | 4 + tests/cn/simplify_array_shift.c.verify | 2 + tests/cn/solver_crash.error.c.verify | 8 ++ .../cn/spec_after_curly_brace.error.c.verify | 6 + tests/cn/spec_null_shift.c.verify | 3 + tests/cn/spec_null_shift.error.c.verify | 9 ++ tests/cn/split_case.c.verify | 2 + tests/cn/struct_updates.error.c.verify | 8 ++ tests/cn/struct_updates2.error.c.verify | 8 ++ tests/cn/swap.c.verify | 20 ++++ tests/cn/swap_pair.c.verify | 20 ++++ tests/cn/tag_defs.c.verify | 2 + tests/cn/to_bytes.error.c.verify | 8 ++ tests/cn/to_from_bytes_block.c.verify | 10 ++ tests/cn/to_from_bytes_owned.c.verify | 14 +++ .../as_auto_mutual_dt/tree16.error.c.verify | 5 + .../tree16/as_mutual_dt/coq_lemmas/Makefile | 6 +- .../as_mutual_dt/coq_lemmas/_CoqProject | 3 - tests/cn/tree16/as_mutual_dt/tree16.c.verify | 15 +++ .../tree16/as_partial_map/coq_lemmas/Makefile | 6 +- .../as_partial_map/coq_lemmas/_CoqProject | 3 - .../cn/tree16/as_partial_map/tree16.c.verify | 22 ++++ tests/cn/tree_rev01.c.verify | 2 + tests/cn/type_synonym.c.verify | 2 + tests/cn/unary_negation.c.verify | 2 + tests/cn/unary_negation.error.c.verify | 4 + tests/cn/unconstrained_ptr_eq.error.c.verify | 9 ++ tests/cn/unconstrained_ptr_eq2.error.c.verify | 9 ++ ...orted_flexible_array_member.error.c.verify | 4 + tests/cn/unsupported_union.error.c.verify | 4 + tests/cn/use_enum.c.verify | 2 + tests/cn/use_typedef.c.verify | 2 + tests/cn/verify.json | 6 + tests/cn/void_star_arg.c.verify | 2 + tests/cn_vip_testsuite/README.md | 13 +++ .../cheri_03_ii.error.c.no_annot | 7 ++ tests/cn_vip_testsuite/no_annot.json | 6 + tests/cn_vip_testsuite/non_det_false.json | 6 + tests/cn_vip_testsuite/non_det_true.json | 6 + ...braic_properties_2_global.annot.c.no_annot | 7 ++ ...aic_properties_2_global.annot.c.with_annot | 2 + ...braic_properties_3_global.annot.c.no_annot | 7 ++ ...aic_properties_3_global.annot.c.with_annot | 2 + ...py_memcpy.c => pointer_copy_memcpy.pass.c} | 0 .../pointer_copy_memcpy.pass.c.no_annot | 14 +++ ...opy_user_ctrlflow_bitwise.annot.c.no_annot | 7 ++ ...y_user_ctrlflow_bitwise.annot.c.with_annot | 2 + ...ointer_copy_user_ctrlflow_bytewise.pass.c} | 0 ...opy_user_ctrlflow_bytewise.pass.c.no_annot | 1 + ...copy_user_dataflow_direct_bytewise.pass.c} | 0 ...r_dataflow_direct_bytewise.pass.c.no_annot | 1 + .../pointer_from_int_disambiguation_1.annot.c | 34 ++++++ ...from_int_disambiguation_1.annot.c.no_annot | 19 +++ ...om_int_disambiguation_1.annot.c.with_annot | 14 +++ ...ter_from_int_disambiguation_1.unprovable.c | 22 ---- ... pointer_from_int_disambiguation_2.pass.c} | 0 ..._from_int_disambiguation_2.pass.c.no_annot | 14 +++ ...from_int_disambiguation_3.error.c.no_annot | 20 ++++ ...om_int_disambiguation_3.error.c.with_annot | 19 +++ ...able.c => pointer_from_integer_1i.annot.c} | 2 + .../pointer_from_integer_1i.annot.c.no_annot | 8 ++ ...pointer_from_integer_1i.annot.c.with_annot | 3 + ...ble.c => pointer_from_integer_1ie.annot.c} | 2 + .../pointer_from_integer_1ie.annot.c.no_annot | 8 ++ ...ointer_from_integer_1ie.annot.c.with_annot | 3 + .../pointer_from_integer_1ig.annot.c.no_annot | 8 ++ ...ointer_from_integer_1ig.annot.c.with_annot | 3 + ...nter_from_integer_1p.unprovable.c.no_annot | 8 ++ ...ter_from_integer_1pg.unprovable.c.no_annot | 8 ++ ...inter_from_integer_2.unprovable.c.no_annot | 8 ++ ...nter_from_integer_2g.unprovable.c.no_annot | 8 ++ ...m_int_subtraction_auto_xy.annot.c.no_annot | 19 +++ ...int_subtraction_auto_xy.annot.c.with_annot | 14 +++ ...m_int_subtraction_auto_yx.annot.c.no_annot | 19 +++ ...int_subtraction_auto_yx.annot.c.with_annot | 14 +++ ...int_subtraction_global_xy.annot.c.no_annot | 19 +++ ...t_subtraction_global_xy.annot.c.with_annot | 14 +++ ...int_subtraction_global_yx.annot.c.no_annot | 19 +++ ...t_subtraction_global_yx.annot.c.with_annot | 14 +++ ...m_ptr_subtraction_auto_xy.error.c.no_annot | 19 +++ ...m_ptr_subtraction_auto_yx.error.c.no_annot | 19 +++ ...ptr_subtraction_global_xy.error.c.no_annot | 19 +++ ...ptr_subtraction_global_yx.error.c.no_annot | 19 +++ .../pointer_offset_xor_auto.annot.c.no_annot | 7 ++ ...pointer_offset_xor_auto.annot.c.with_annot | 2 + ...pointer_offset_xor_global.annot.c.no_annot | 7 ++ ...inter_offset_xor_global.annot.c.with_annot | 2 + .../provenance_basic_auto_yx.error.c.no_annot | 19 +++ ...rovenance_basic_global_yx.error.c.no_annot | 19 +++ ...c_using_uintptr_t_auto_yx.annot.c.no_annot | 19 +++ ...using_uintptr_t_auto_yx.annot.c.with_annot | 14 +++ ...using_uintptr_t_global_yx.annot.c.no_annot | 19 +++ ...ing_uintptr_t_global_yx.annot.c.with_annot | 14 +++ ...c => provenance_equality_auto_yx.nondet.c} | 0 ...venance_equality_auto_yx.nondet.c.no_annot | 2 + ...ce_equality_auto_yx.nondet.c.non_det_false | 9 ++ ...nce_equality_auto_yx.nondet.c.non_det_true | 9 ++ ...rovenance_equality_auto_yx.pass.c.no_annot | 2 + ...provenance_equality_global_fn_yx.nondet.c} | 0 ...ce_equality_global_fn_yx.nondet.c.no_annot | 3 + ...uality_global_fn_yx.nondet.c.non_det_false | 10 ++ ...quality_global_fn_yx.nondet.c.non_det_true | 10 ++ ...ance_equality_global_fn_yx.pass.c.no_annot | 3 + ...=> provenance_equality_global_yx.nondet.c} | 0 ...nance_equality_global_yx.nondet.c.no_annot | 2 + ..._equality_global_yx.nondet.c.non_det_false | 9 ++ ...e_equality_global_yx.nondet.c.non_det_true | 9 ++ ...venance_equality_global_yx.pass.c.no_annot | 2 + ...venance_equality_uintptr_t_auto_yx.pass.c} | 0 ...equality_uintptr_t_auto_yx.pass.c.no_annot | 2 + ...nance_equality_uintptr_t_global_yx.pass.c} | 0 ...uality_uintptr_t_global_yx.pass.c.no_annot | 2 + .../provenance_lost_escape_1.annot.c.no_annot | 19 +++ ...rovenance_lost_escape_1.annot.c.with_annot | 14 +++ ... provenance_roundtrip_via_intptr_t.pass.c} | 0 ...nce_roundtrip_via_intptr_t.pass.c.no_annot | 2 + ...nce_roundtrip_via_intptr_t_onepast.pass.c} | 0 ...dtrip_via_intptr_t_onepast.pass.c.no_annot | 2 + ...rovenance_tag_bits_via_repr_byte_1.pass.c} | 0 ...e_tag_bits_via_repr_byte_1.pass.c.no_annot | 8 ++ ..._tag_bits_via_uintptr_t_1.annot.c.no_annot | 7 ++ ...ag_bits_via_uintptr_t_1.annot.c.with_annot | 2 + ...e_union_punning_2_auto_yx.error.c.no_annot | 4 + ...union_punning_2_global_yx.error.c.no_annot | 4 + ... provenance_union_punning_3_global.pass.c} | 0 ...nce_union_punning_3_global.pass.c.no_annot | 4 + tests/cn_vip_testsuite/with_annot.json | 6 + tests/diff-prog.py | 110 ++++++++++++++++++ tests/run-cn-lemmas.sh | 42 +++++++ tests/run-cn-tutorial-ci.sh | 3 - tests/run-cn-vip.sh | 99 +--------------- tests/run-cn.sh | 2 + 277 files changed, 1956 insertions(+), 160 deletions(-) create mode 100644 tests/cn/alloc_create.c.verify create mode 100644 tests/cn/alloc_token.c.verify create mode 100644 tests/cn/and_or_precedence.error.c.verify create mode 100644 tests/cn/append.c.verify create mode 100644 tests/cn/arith_type.error.c.verify create mode 100644 tests/cn/arrow_access.c.verify create mode 100644 tests/cn/assert_on_toplevel.error.c.verify create mode 100644 tests/cn/b_or.c.verify create mode 100644 tests/cn/b_xor.c.verify create mode 100644 tests/cn/bad_col.error.c.verify create mode 100644 tests/cn/bad_constructor_user.error.c.verify create mode 100644 tests/cn/bad_function_call.error.c.verify create mode 100644 tests/cn/bad_record.error.c.verify create mode 100644 tests/cn/bad_record2.error.c.verify create mode 100644 tests/cn/bad_recursion.error.c.verify create mode 100644 tests/cn/bad_resource_var.error.c.verify create mode 100644 tests/cn/before_from_bytes.error.c.verify create mode 100644 tests/cn/before_to_bytes.error.c.verify create mode 100644 tests/cn/bitwise_and.c.verify create mode 100644 tests/cn/bitwise_and_type_left.error.c.verify create mode 100644 tests/cn/bitwise_and_type_right.error.c.verify create mode 100644 tests/cn/bitwise_compl.c.verify create mode 100644 tests/cn/bitwise_compl_precedence.c.verify create mode 100644 tests/cn/bitwise_compl_type.error.c.verify create mode 100644 tests/cn/block_type.c.verify create mode 100644 tests/cn/builtin_ctz.c.verify create mode 100644 tests/cn/builtin_ctz_val.c.verify create mode 100644 tests/cn/cn_inline.c.verify create mode 100644 tests/cn/cnfunction_mismatched_args1.error.c.verify create mode 100644 tests/cn/cnfunction_mismatched_args2.error.c.verify create mode 100644 tests/cn/cnfunction_mismatched_args3.error.c.verify create mode 100644 tests/cn/cnfunction_mismatched_args4.error.c.verify create mode 100644 tests/cn/copy_alloc_id.c.verify create mode 100644 tests/cn/copy_alloc_id.error.c.verify create mode 100644 tests/cn/copy_alloc_id2.error.c.verify create mode 100644 tests/cn/create_rdonly.c.verify create mode 100644 tests/cn/disj_nonnull.c.verify create mode 100644 tests/cn/division.c.verify create mode 100644 tests/cn/division_by_0.error.c.verify create mode 100644 tests/cn/division_casting.c.verify create mode 100644 tests/cn/division_precedence.c.verify create mode 100644 tests/cn/division_return_sign.error.c.verify create mode 100644 tests/cn/division_return_size.error.c.verify create mode 100644 tests/cn/division_with_constants.c.verify create mode 100644 tests/cn/doubling.c.verify create mode 100644 tests/cn/duplicate_datatype_var.error.c.verify create mode 100644 tests/cn/duplicate_pattern_var.error.c.verify create mode 100644 tests/cn/enum_and_and.c.verify create mode 100644 tests/cn/extract_verbose.c.verify create mode 100644 tests/cn/failing_postcond.error.c.verify create mode 100644 tests/cn/failing_precond.error.c.verify create mode 100644 tests/cn/forloop_with_decl.c.verify create mode 100644 tests/cn/from_bytes.error.c.verify create mode 100644 tests/cn/fun_addrs_cn_stmt.c.verify create mode 100644 tests/cn/fun_ptr_extern.c.verify create mode 100644 tests/cn/fun_ptr_known.c.verify create mode 100644 tests/cn/fun_ptr_three_opts.c.verify create mode 100644 tests/cn/get_from_arr.c.verify create mode 100644 tests/cn/get_from_array.c.verify create mode 100644 tests/cn/ghost_pointer_to_bitvec_cast.c.verify create mode 100644 tests/cn/gnu_case_ranges.c.verify create mode 100644 tests/cn/gnu_choose.c.verify create mode 100644 tests/cn/gnu_ctz.c.verify create mode 100644 tests/cn/gnu_ffs.c.verify create mode 100644 tests/cn/gnu_types_compatible.c.verify create mode 100644 tests/cn/has_alloc_id.c.verify create mode 100644 tests/cn/has_alloc_id.error.c.verify create mode 100644 tests/cn/has_alloc_id_ptr_eq.error.c.verify create mode 100644 tests/cn/has_alloc_id_ptr_eq2.error.c.verify create mode 100644 tests/cn/has_alloc_id_ptr_neq.c.verify create mode 100644 tests/cn/has_alloc_id_ptr_neq.error.c.verify create mode 100644 tests/cn/has_alloc_id_shift.c.verify create mode 100644 tests/cn/implies.c.verify create mode 100644 tests/cn/implies2.error.c.verify create mode 100644 tests/cn/implies3.error.c.verify create mode 100644 tests/cn/implies_associativity.c.verify create mode 100644 tests/cn/implies_precedence.c.verify create mode 100644 tests/cn/incomplete_match.error.c.verify create mode 100644 tests/cn/inconsistent.error.c.verify create mode 100644 tests/cn/inconsistent2.error.c.verify create mode 100644 tests/cn/inconsistent3.error.c.verify create mode 100644 tests/cn/increments.c.verify create mode 100644 tests/cn/int_to_ptr.c.verify create mode 100644 tests/cn/int_to_ptr.error.c.verify create mode 100644 tests/cn/left_shift_const.c.verify create mode 100644 tests/cn/lexer_hack_parse.error.c.verify create mode 100644 tests/cn/list_literal_type.error.c.verify create mode 100644 tests/cn/list_rev01.c.verify create mode 100644 tests/cn/magic_comment_not_closed.c.verify create mode 100644 tests/cn/map_set.error.c.verify create mode 100644 tests/cn/mask_ptr.c.verify create mode 100644 tests/cn/match.c.verify create mode 100644 tests/cn/max_min_consts.c.verify create mode 100644 tests/cn/max_pipes.error.c.verify create mode 100644 tests/cn/memcpy.c.verify create mode 100644 tests/cn/mergesort.c.verify create mode 100644 tests/cn/mergesort_alt.c.verify create mode 100644 tests/cn/merging_arrays.error.c.verify create mode 100644 tests/cn/missing_resource.error.c.verify create mode 100644 tests/cn/missing_resource_indirect.error.c.verify create mode 100644 tests/cn/mod.c.verify create mode 100644 tests/cn/mod_by_0.error.c.verify create mode 100644 tests/cn/mod_casting.c.verify create mode 100644 tests/cn/mod_precedence.c.verify create mode 100644 tests/cn/mod_return_sign.error.c.verify create mode 100644 tests/cn/mod_return_size.error.c.verify create mode 100644 tests/cn/mod_with_constants.c.verify create mode 100644 tests/cn/multifile/f.c.verify create mode 100644 tests/cn/multifile/g.c.verify delete mode 100644 tests/cn/mutual_rec/build.sh create mode 100644 tests/cn/mutual_rec/mutual_rec1.c.verify create mode 100644 tests/cn/mutual_rec/mutual_rec2.c.verify create mode 100644 tests/cn/mutual_rec/mutual_rec3.c.verify create mode 100644 tests/cn/null_to_int.c.verify create mode 100644 tests/cn/ownership_at_negative_index.c.verify create mode 100644 tests/cn/partial_init_bytes.error.c.verify create mode 100644 tests/cn/pointer_to_char_cast.c.verify create mode 100644 tests/cn/pointer_to_char_cast.error.c.verify create mode 100644 tests/cn/pointer_to_int_cast.error.c.verify create mode 100644 tests/cn/pointer_to_intptr_t_cast.c.verify create mode 100644 tests/cn/pointer_to_uintptr_t_cast.c.verify create mode 100644 tests/cn/pointer_to_unsigned_int_cast.error.c.verify create mode 100644 tests/cn/pred_def01.c.verify create mode 100644 tests/cn/pred_def02.c.verify create mode 100644 tests/cn/pred_def03.error.c.verify create mode 100644 tests/cn/pred_def04.c.verify create mode 100644 tests/cn/previously_inconsistent_assumptions1.c.verify create mode 100644 tests/cn/previously_inconsistent_assumptions2.c.verify create mode 100644 tests/cn/ptr_diff.c.verify create mode 100644 tests/cn/ptr_diff.error.c.verify create mode 100644 tests/cn/ptr_diff2.c.verify create mode 100644 tests/cn/ptr_diff2.error.c.verify create mode 100644 tests/cn/ptr_relop.c.verify create mode 100644 tests/cn/ptr_relop.error.c.verify create mode 100644 tests/cn/record1.c.verify create mode 100644 tests/cn/redundant_pattern.error.c.verify create mode 100644 tests/cn/reverse.c.verify create mode 100644 tests/cn/reverse.error.c.verify create mode 100644 tests/cn/shift_diff_sz.c.verify create mode 100644 tests/cn/simple_loop.c.verify create mode 100644 tests/cn/simplify_add_0.c.verify create mode 100644 tests/cn/simplify_array_shift.c.verify create mode 100644 tests/cn/solver_crash.error.c.verify create mode 100644 tests/cn/spec_after_curly_brace.error.c.verify create mode 100644 tests/cn/spec_null_shift.c.verify create mode 100644 tests/cn/spec_null_shift.error.c.verify create mode 100644 tests/cn/split_case.c.verify create mode 100644 tests/cn/struct_updates.error.c.verify create mode 100644 tests/cn/struct_updates2.error.c.verify create mode 100644 tests/cn/swap.c.verify create mode 100644 tests/cn/swap_pair.c.verify create mode 100644 tests/cn/tag_defs.c.verify create mode 100644 tests/cn/to_bytes.error.c.verify create mode 100644 tests/cn/to_from_bytes_block.c.verify create mode 100644 tests/cn/to_from_bytes_owned.c.verify create mode 100644 tests/cn/tree16/as_auto_mutual_dt/tree16.error.c.verify create mode 100644 tests/cn/tree16/as_mutual_dt/tree16.c.verify create mode 100644 tests/cn/tree16/as_partial_map/tree16.c.verify create mode 100644 tests/cn/tree_rev01.c.verify create mode 100644 tests/cn/type_synonym.c.verify create mode 100644 tests/cn/unary_negation.c.verify create mode 100644 tests/cn/unary_negation.error.c.verify create mode 100644 tests/cn/unconstrained_ptr_eq.error.c.verify create mode 100644 tests/cn/unconstrained_ptr_eq2.error.c.verify create mode 100644 tests/cn/unsupported_flexible_array_member.error.c.verify create mode 100644 tests/cn/unsupported_union.error.c.verify create mode 100644 tests/cn/use_enum.c.verify create mode 100644 tests/cn/use_typedef.c.verify create mode 100644 tests/cn/verify.json create mode 100644 tests/cn/void_star_arg.c.verify create mode 100644 tests/cn_vip_testsuite/README.md create mode 100644 tests/cn_vip_testsuite/cheri_03_ii.error.c.no_annot create mode 100644 tests/cn_vip_testsuite/no_annot.json create mode 100644 tests/cn_vip_testsuite/non_det_false.json create mode 100644 tests/cn_vip_testsuite/non_det_true.json create mode 100644 tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.with_annot rename tests/cn_vip_testsuite/{pointer_copy_memcpy.c => pointer_copy_memcpy.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.with_annot rename tests/cn_vip_testsuite/{pointer_copy_user_ctrlflow_bytewise.unprovable.c => pointer_copy_user_ctrlflow_bytewise.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c.no_annot rename tests/cn_vip_testsuite/{pointer_copy_user_dataflow_direct_bytewise.c => pointer_copy_user_dataflow_direct_bytewise.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c create mode 100644 tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot delete mode 100644 tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.unprovable.c rename tests/cn_vip_testsuite/{pointer_from_int_disambiguation_2.c => pointer_from_int_disambiguation_2.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot rename tests/cn_vip_testsuite/{pointer_from_integer_1i.unprovable.c => pointer_from_integer_1i.annot.c} (84%) create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.with_annot rename tests/cn_vip_testsuite/{pointer_from_integer_1ie.unprovable.c => pointer_from_integer_1ie.annot.c} (86%) create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot rename tests/cn_vip_testsuite/{provenance_equality_auto_yx.c => provenance_equality_auto_yx.nondet.c} (100%) create mode 100644 tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false create mode 100644 tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true create mode 100644 tests/cn_vip_testsuite/provenance_equality_auto_yx.pass.c.no_annot rename tests/cn_vip_testsuite/{provenance_equality_global_fn_yx.c => provenance_equality_global_fn_yx.nondet.c} (100%) create mode 100644 tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false create mode 100644 tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true create mode 100644 tests/cn_vip_testsuite/provenance_equality_global_fn_yx.pass.c.no_annot rename tests/cn_vip_testsuite/{provenance_equality_global_yx.c => provenance_equality_global_yx.nondet.c} (100%) create mode 100644 tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false create mode 100644 tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true create mode 100644 tests/cn_vip_testsuite/provenance_equality_global_yx.pass.c.no_annot rename tests/cn_vip_testsuite/{provenance_equality_uintptr_t_auto_yx.c => provenance_equality_uintptr_t_auto_yx.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c.no_annot rename tests/cn_vip_testsuite/{provenance_equality_uintptr_t_global_yx.c => provenance_equality_uintptr_t_global_yx.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot rename tests/cn_vip_testsuite/{provenance_roundtrip_via_intptr_t.c => provenance_roundtrip_via_intptr_t.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c.no_annot rename tests/cn_vip_testsuite/{provenance_roundtrip_via_intptr_t_onepast.c => provenance_roundtrip_via_intptr_t_onepast.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c.no_annot rename tests/cn_vip_testsuite/{provenance_tag_bits_via_repr_byte_1.c => provenance_tag_bits_via_repr_byte_1.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.with_annot create mode 100644 tests/cn_vip_testsuite/provenance_union_punning_2_auto_yx.error.c.no_annot create mode 100644 tests/cn_vip_testsuite/provenance_union_punning_2_global_yx.error.c.no_annot rename tests/cn_vip_testsuite/{provenance_union_punning_3_global.c => provenance_union_punning_3_global.pass.c} (100%) create mode 100644 tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c.no_annot create mode 100644 tests/cn_vip_testsuite/with_annot.json create mode 100755 tests/diff-prog.py create mode 100755 tests/run-cn-lemmas.sh diff --git a/.github/workflows/ci-cn-spec-testing.yml b/.github/workflows/ci-cn-spec-testing.yml index 69166b5ef..1827be49e 100644 --- a/.github/workflows/ci-cn-spec-testing.yml +++ b/.github/workflows/ci-cn-spec-testing.yml @@ -80,5 +80,5 @@ jobs: run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-cn-test-gen.sh + cd tests; ./run-cn-test-gen.sh diff --git a/.github/workflows/ci-cn.yml b/.github/workflows/ci-cn.yml index 7889d279c..01d91eec8 100644 --- a/.github/workflows/ci-cn.yml +++ b/.github/workflows/ci-cn.yml @@ -71,7 +71,7 @@ jobs: run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - USE_OPAM='' cd backend/cn && dune build @fmt + cd backend/cn && dune build @fmt - name: Checkout cn-tutorial uses: actions/checkout@v4 @@ -79,20 +79,20 @@ jobs: repository: rems-project/cn-tutorial path: cn-tutorial - - name: Run CN CI tests + - name: Run CN tests run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-cn.sh + ./tests/diff-prog.py cn tests/cn/verify.json 2> diff.patch || (cat diff.patch; exit 1) - - name: Run CN Tutorial CI tests + - name: Run CN Tutorial tests run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - USE_OPAM='' tests/run-cn-tutorial-ci.sh cn-tutorial + tests/run-cn-tutorial-ci.sh cn-tutorial - - name: Run CN VIP CI tests + - name: Run CN VIP tests run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-cn-vip.sh + tests/run-cn-vip.sh diff --git a/.github/workflows/ci-pr-bench.yml.disabled b/.github/workflows/ci-pr-bench.yml.disabled index 534460f5d..866ba4a68 100644 --- a/.github/workflows/ci-pr-bench.yml.disabled +++ b/.github/workflows/ci-pr-bench.yml.disabled @@ -90,7 +90,7 @@ jobs: run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-ci-benchmarks.sh + cd tests; ./run-ci-benchmarks.sh mv benchmark-data.json ${{ env.PR_DATA }} cd .. @@ -117,7 +117,7 @@ jobs: run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-ci-benchmarks.sh; mv benchmark-data.json ${{ env.BASE_DATA }} + cd tests; ./run-ci-benchmarks.sh; mv benchmark-data.json ${{ env.BASE_DATA }} cd .. - name: Compare results diff --git a/tests/cn/alloc_create.c.verify b/tests/cn/alloc_create.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/alloc_create.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/alloc_token.c.verify b/tests/cn/alloc_token.c.verify new file mode 100644 index 000000000..e1522bb41 --- /dev/null +++ b/tests/cn/alloc_token.c.verify @@ -0,0 +1 @@ +return code: 0 diff --git a/tests/cn/and_or_precedence.error.c.verify b/tests/cn/and_or_precedence.error.c.verify new file mode 100644 index 000000000..dab54766c --- /dev/null +++ b/tests/cn/and_or_precedence.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: g1 -- fail +tests/cn/and_or_precedence.error.c:15:13: error: Unprovable constraint + /*@ assert (false); @*/ + ^~~~~~~~~~~~~~~ +Constraint from tests/cn/and_or_precedence.error.c:15:13: + /*@ assert (false); @*/ + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__and_or_precedence.error.c__g1.html diff --git a/tests/cn/append.c.verify b/tests/cn/append.c.verify new file mode 100644 index 000000000..88a4dc256 --- /dev/null +++ b/tests/cn/append.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: IntList_append -- pass +[2/2]: split -- pass diff --git a/tests/cn/arith_type.error.c.verify b/tests/cn/arith_type.error.c.verify new file mode 100644 index 000000000..89c33c743 --- /dev/null +++ b/tests/cn/arith_type.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/arith_type.error.c:8:21: error: Type error + let x = negate() + true; + ^ +Expression 'true' has type 'boolean'. +I expected it to have type 'integer' because of tests/cn/arith_type.error.c:8:10: + let x = negate() + true; + ~~~~~~^~ diff --git a/tests/cn/arrow_access.c.verify b/tests/cn/arrow_access.c.verify new file mode 100644 index 000000000..e451e2eea --- /dev/null +++ b/tests/cn/arrow_access.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: arrow_access_1 -- pass +[2/2]: arrow_access_2 -- pass diff --git a/tests/cn/assert_on_toplevel.error.c.verify b/tests/cn/assert_on_toplevel.error.c.verify new file mode 100644 index 000000000..81eb93822 --- /dev/null +++ b/tests/cn/assert_on_toplevel.error.c.verify @@ -0,0 +1,5 @@ +return code: 2 +tests/cn/assert_on_toplevel.error.c:2:5: error: unexpected token before 'assert' +parsing "cn_toplevel'": expected "cn_toplevel" + assert @*/ + ^~~~~~ diff --git a/tests/cn/b_or.c.verify b/tests/cn/b_or.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/b_or.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/b_xor.c.verify b/tests/cn/b_xor.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/b_xor.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/bad_col.error.c.verify b/tests/cn/bad_col.error.c.verify new file mode 100644 index 000000000..448606b92 --- /dev/null +++ b/tests/cn/bad_col.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/bad_col.error.c:3:32: error: unexpected token after '+' and before 'function' +parsing "add_expr": seen "add_expr PLUS", expecting "mul_expr" + x < 2147483647 + function; @*/ + ^~~~~~~~ diff --git a/tests/cn/bad_constructor_user.error.c.verify b/tests/cn/bad_constructor_user.error.c.verify new file mode 100644 index 000000000..896996060 --- /dev/null +++ b/tests/cn/bad_constructor_user.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/bad_constructor_user.error.c:9:19: error: Type error + Cons { head : 0, tail : Nil {} } + ^ +Expression '0' has type 'integer'. +I expected it to have type 'i32' because of tests/cn/bad_constructor_user.error.c:9:5: + Cons { head : 0, tail : Nil {} } + ~~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/bad_function_call.error.c.verify b/tests/cn/bad_function_call.error.c.verify new file mode 100644 index 000000000..54d2810f6 --- /dev/null +++ b/tests/cn/bad_function_call.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/bad_function_call.error.c:7:12: error: Type error + id_int(x) + ^ +Expression 'x' has type 'i32'. +I expected it to have type 'integer' because of tests/cn/bad_function_call.error.c:2:1: +function (integer) id_int(integer x) { +^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/bad_record.error.c.verify b/tests/cn/bad_record.error.c.verify new file mode 100644 index 000000000..bb6d84cbe --- /dev/null +++ b/tests/cn/bad_record.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/bad_record.error.c:3:43: error: field `x' duplicated +type_synonym wrong = { integer x, integer x } + ^ diff --git a/tests/cn/bad_record2.error.c.verify b/tests/cn/bad_record2.error.c.verify new file mode 100644 index 000000000..3988a0513 --- /dev/null +++ b/tests/cn/bad_record2.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/bad_record2.error.c:6:15: error: field `x' duplicated + { x: p.x, x: p.y } + ^ diff --git a/tests/cn/bad_recursion.error.c.verify b/tests/cn/bad_recursion.error.c.verify new file mode 100644 index 000000000..5f7a54443 --- /dev/null +++ b/tests/cn/bad_recursion.error.c.verify @@ -0,0 +1,6 @@ +return code: 1 +tests/cn/bad_recursion.error.c:3:1: error: Illegal datatype definition. +Constructor argument 'b' is given type 'map', which indirectly refers to 'datatype bad'. +Indirect recursion via map, set, record, or tuple types is not permitted. +datatype bad { Bad { map b } } +^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/bad_resource_var.error.c.verify b/tests/cn/bad_resource_var.error.c.verify new file mode 100644 index 000000000..1fa821a13 --- /dev/null +++ b/tests/cn/bad_resource_var.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: inc -- fail +tests/cn/bad_resource_var.error.c:1:1: error: Unprovable constraint +void inc(int* p) +~~~~~^~~~~~~~~~~ +Constraint from tests/cn/bad_resource_var.error.c:5:13: + X2 < 2147483647i32; @*/ + ^~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__bad_resource_var.error.c__inc.html diff --git a/tests/cn/before_from_bytes.error.c.verify b/tests/cn/before_from_bytes.error.c.verify new file mode 100644 index 000000000..dab7dd396 --- /dev/null +++ b/tests/cn/before_from_bytes.error.c.verify @@ -0,0 +1,13 @@ +return code: 1 +tests/cn/before_from_bytes.error.c:6:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Owned(p); @*/ + ^~~~~~~~ +tests/cn/before_from_bytes.error.c:7:9: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 2u64; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: main -- fail +tests/cn/before_from_bytes.error.c:8:5: error: Missing resource for writing + p_char[2] = 0xff; + ~~~~~~~~~~^~~~~~ +Resource needed: Block(&&x[(u64)2'i32]) +State file: file:///tmp/state__before_from_bytes.error.c__main.html diff --git a/tests/cn/before_to_bytes.error.c.verify b/tests/cn/before_to_bytes.error.c.verify new file mode 100644 index 000000000..9b0a8a511 --- /dev/null +++ b/tests/cn/before_to_bytes.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn/before_to_bytes.error.c:6:5: error: Missing resource for writing + p_char[2] = 0xff; + ~~~~~~~~~~^~~~~~ +Resource needed: Block(&&x[(u64)2'i32]) +State file: file:///tmp/state__before_to_bytes.error.c__main.html diff --git a/tests/cn/bitwise_and.c.verify b/tests/cn/bitwise_and.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/bitwise_and.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/bitwise_and_type_left.error.c.verify b/tests/cn/bitwise_and_type_left.error.c.verify new file mode 100644 index 000000000..be59b8dd1 --- /dev/null +++ b/tests/cn/bitwise_and_type_left.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/bitwise_and_type_left.error.c:3:17: error: Ill-typed application of binary operation '&' . + /*@ assert (0 & 1i32 == 0i32); @*/ + ~~^~~~~~ +'0' has type 'integer', '1'i32' has type 'i32'. diff --git a/tests/cn/bitwise_and_type_right.error.c.verify b/tests/cn/bitwise_and_type_right.error.c.verify new file mode 100644 index 000000000..bcfa695e6 --- /dev/null +++ b/tests/cn/bitwise_and_type_right.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/bitwise_and_type_right.error.c:3:24: error: Type error + /*@ assert (0i32 & 1 == 0i32); @*/ + ^ +Expression '1' has type 'integer'. +I expected it to have type 'i32' because of tests/cn/bitwise_and_type_right.error.c:3:17: + /*@ assert (0i32 & 1 == 0i32); @*/ + ^ diff --git a/tests/cn/bitwise_compl.c.verify b/tests/cn/bitwise_compl.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/bitwise_compl.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/bitwise_compl_precedence.c.verify b/tests/cn/bitwise_compl_precedence.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/bitwise_compl_precedence.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/bitwise_compl_type.error.c.verify b/tests/cn/bitwise_compl_type.error.c.verify new file mode 100644 index 000000000..c21c11f6c --- /dev/null +++ b/tests/cn/bitwise_compl_type.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/bitwise_compl_type.error.c:3:18: error: Mismatched types. + /*@ assert (~0 == -1); @*/ + ^ +Expected value of type 'bitvector' but found value of type 'integer' diff --git a/tests/cn/block_type.c.verify b/tests/cn/block_type.c.verify new file mode 100644 index 000000000..1bb6cba68 --- /dev/null +++ b/tests/cn/block_type.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: block_notype_1 -- pass +[2/2]: block_notype_2 -- pass diff --git a/tests/cn/builtin_ctz.c.verify b/tests/cn/builtin_ctz.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/builtin_ctz.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/builtin_ctz_val.c.verify b/tests/cn/builtin_ctz_val.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/builtin_ctz_val.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/cn_inline.c.verify b/tests/cn/cn_inline.c.verify new file mode 100644 index 000000000..5e3efbb37 --- /dev/null +++ b/tests/cn/cn_inline.c.verify @@ -0,0 +1,6 @@ +return code: 0 +tests/cn/cn_inline.c:13:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function lookup_size_shift_cn; @*/ + ^~~~~~~~~~~ +[1/2]: lookup_size_shift -- pass +[2/2]: f -- pass diff --git a/tests/cn/cnfunction_mismatched_args1.error.c.verify b/tests/cn/cnfunction_mismatched_args1.error.c.verify new file mode 100644 index 000000000..c58d4f650 --- /dev/null +++ b/tests/cn/cnfunction_mismatched_args1.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +tests/cn/cnfunction_mismatched_args1.error.c:6:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~ +tests/cn/cnfunction_mismatched_args1.error.c:5:1: error: mismatched argument number for c_bw_or -> bw_or +int c_bw_or(int x) +~~~~^~~~~~~~~~~~~~ diff --git a/tests/cn/cnfunction_mismatched_args2.error.c.verify b/tests/cn/cnfunction_mismatched_args2.error.c.verify new file mode 100644 index 000000000..d357d91a4 --- /dev/null +++ b/tests/cn/cnfunction_mismatched_args2.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +tests/cn/cnfunction_mismatched_args2.error.c:6:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~ +tests/cn/cnfunction_mismatched_args2.error.c:5:1: error: mismatched argument number for c_bw_or -> bw_or +int c_bw_or(int x, int y, int z) +~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/cnfunction_mismatched_args3.error.c.verify b/tests/cn/cnfunction_mismatched_args3.error.c.verify new file mode 100644 index 000000000..09416403a --- /dev/null +++ b/tests/cn/cnfunction_mismatched_args3.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +tests/cn/cnfunction_mismatched_args3.error.c:6:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~ +tests/cn/cnfunction_mismatched_args3.error.c:5:1: error: mismatched arguments: (u32 y) and (i32 y) +int c_bw_or(int x, int y) +~~~~^~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/cnfunction_mismatched_args4.error.c.verify b/tests/cn/cnfunction_mismatched_args4.error.c.verify new file mode 100644 index 000000000..a46ca7b5e --- /dev/null +++ b/tests/cn/cnfunction_mismatched_args4.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/cnfunction_mismatched_args4.error.c:6:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~ +tests/cn/cnfunction_mismatched_args4.error.c:6:5: error: cn_function: return-type mismatch: +c_bw_or : i32 -> bw_or : u32 +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/copy_alloc_id.c.verify b/tests/cn/copy_alloc_id.c.verify new file mode 100644 index 000000000..403d4a98c --- /dev/null +++ b/tests/cn/copy_alloc_id.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: f1 -- pass +[2/3]: f2 -- pass +[3/3]: main -- pass diff --git a/tests/cn/copy_alloc_id.error.c.verify b/tests/cn/copy_alloc_id.error.c.verify new file mode 100644 index 000000000..1912b9b83 --- /dev/null +++ b/tests/cn/copy_alloc_id.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/copy_alloc_id.error.c:4:12: error: Pointer `p` needs allocation ID + int* q = __cerbvar_copy_alloc_id(p_int + 0ULL, p); + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(UB missing short message): UB_CERB004_unspecified__copy_alloc_id +State file: file:///tmp/state__copy_alloc_id.error.c__f.html diff --git a/tests/cn/copy_alloc_id2.error.c.verify b/tests/cn/copy_alloc_id2.error.c.verify new file mode 100644 index 000000000..49f644d43 --- /dev/null +++ b/tests/cn/copy_alloc_id2.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/copy_alloc_id2.error.c:10:12: error: Pointer `p` needs to be live for copy_alloc_id + int* q = __cerbvar_copy_alloc_id(p_int + 0ULL, p); + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Need an Alloc or Owned in context with same allocation id +State file: file:///tmp/state__copy_alloc_id2.error.c__f.html diff --git a/tests/cn/create_rdonly.c.verify b/tests/cn/create_rdonly.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/create_rdonly.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/disj_nonnull.c.verify b/tests/cn/disj_nonnull.c.verify new file mode 100644 index 000000000..aebb850c1 --- /dev/null +++ b/tests/cn/disj_nonnull.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: globals -- pass +[2/2]: main -- pass diff --git a/tests/cn/division.c.verify b/tests/cn/division.c.verify new file mode 100644 index 000000000..49eb5132a --- /dev/null +++ b/tests/cn/division.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: division -- pass diff --git a/tests/cn/division_by_0.error.c.verify b/tests/cn/division_by_0.error.c.verify new file mode 100644 index 000000000..26b354deb --- /dev/null +++ b/tests/cn/division_by_0.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: division -- fail +tests/cn/division_by_0.error.c:6:12: error: Undefined behaviour + return x / y; + ~~^~~ +the value of the second operand of a '/' operator is zero (§6.5.5#5, sentence 2) +State file: file:///tmp/state__division_by_0.error.c__division.html diff --git a/tests/cn/division_casting.c.verify b/tests/cn/division_casting.c.verify new file mode 100644 index 000000000..49eb5132a --- /dev/null +++ b/tests/cn/division_casting.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: division -- pass diff --git a/tests/cn/division_precedence.c.verify b/tests/cn/division_precedence.c.verify new file mode 100644 index 000000000..1b05d9f8a --- /dev/null +++ b/tests/cn/division_precedence.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: divide_no_parenthesis -- pass +[2/3]: multiply_then_divide -- pass +[3/3]: divide_multiply_add_subtract -- pass diff --git a/tests/cn/division_return_sign.error.c.verify b/tests/cn/division_return_sign.error.c.verify new file mode 100644 index 000000000..f12610a77 --- /dev/null +++ b/tests/cn/division_return_sign.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/division_return_sign.error.c:7:25: error: Type error + ensures return == x/y; @*/ + ^ +Expression 'y' has type 'u32'. +I expected it to have type 'i32' because of tests/cn/division_return_sign.error.c:7:23: + ensures return == x/y; @*/ + ^ diff --git a/tests/cn/division_return_size.error.c.verify b/tests/cn/division_return_size.error.c.verify new file mode 100644 index 000000000..d059aaf6f --- /dev/null +++ b/tests/cn/division_return_size.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: different_size -- fail +tests/cn/division_return_size.error.c:9:5: error: integer value not representable at type signed int + return x / y; + ^~~~~~~~~~~~~ +Value: (i64)x / y +State file: file:///tmp/state__division_return_size.error.c__different_size.html diff --git a/tests/cn/division_with_constants.c.verify b/tests/cn/division_with_constants.c.verify new file mode 100644 index 000000000..892106973 --- /dev/null +++ b/tests/cn/division_with_constants.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: divide_by_ten -- pass +[2/3]: divide_by_neg_ten -- pass +[3/3]: division_diff_sign -- pass diff --git a/tests/cn/doubling.c.verify b/tests/cn/doubling.c.verify new file mode 100644 index 000000000..e21c36d77 --- /dev/null +++ b/tests/cn/doubling.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: add_self -- pass +[2/2]: add_self_twice -- pass diff --git a/tests/cn/duplicate_datatype_var.error.c.verify b/tests/cn/duplicate_datatype_var.error.c.verify new file mode 100644 index 000000000..994b33506 --- /dev/null +++ b/tests/cn/duplicate_datatype_var.error.c.verify @@ -0,0 +1,4 @@ +return code: 1 +tests/cn/duplicate_datatype_var.error.c:5:22: error: Re-using member name x within datatype definition. + Single { integer x } + ^ diff --git a/tests/cn/duplicate_pattern_var.error.c.verify b/tests/cn/duplicate_pattern_var.error.c.verify new file mode 100644 index 000000000..b4c60a1e6 --- /dev/null +++ b/tests/cn/duplicate_pattern_var.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/duplicate_pattern_var.error.c:15:43: error: redeclaration of variable + Cons { head : Point { x : a , y : a } , tail : tail } => { a + b + sum(tail) } + ^ diff --git a/tests/cn/enum_and_and.c.verify b/tests/cn/enum_and_and.c.verify new file mode 100644 index 000000000..7213715e9 --- /dev/null +++ b/tests/cn/enum_and_and.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: foo -- pass diff --git a/tests/cn/extract_verbose.c.verify b/tests/cn/extract_verbose.c.verify new file mode 100644 index 000000000..1a3d525ad --- /dev/null +++ b/tests/cn/extract_verbose.c.verify @@ -0,0 +1,23 @@ +return code: 0 +tests/cn/extract_verbose.c:10:27: warning: 'extract' expects a 'u64', but '1' with type 'integer' was provided. This will become an error in the future. + /*@ extract Owned, 1; @*/ + ^ +tests/cn/extract_verbose.c:11:27: warning: 'extract' expects a 'u64', but '1' with type 'integer' was provided. This will become an error in the future. + /*@ extract Owned, 1; @*/ + ^ +tests/cn/extract_verbose.c:14:27: warning: 'extract' expects a 'u64', but '12' with type 'integer' was provided. This will become an error in the future. + /*@ extract Owned, 12; @*/ + ^ +tests/cn/extract_verbose.c:10:7: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 1; @*/ + ^~~~~~~~~~~~~~~~~~~~~~ +tests/cn/extract_verbose.c:11:7: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 1; @*/ + ^~~~~~~~~~~~~~~~~~~~~~ +tests/cn/extract_verbose.c:13:7: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 1u64; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~ +tests/cn/extract_verbose.c:14:7: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 12; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: f -- pass diff --git a/tests/cn/failing_postcond.error.c.verify b/tests/cn/failing_postcond.error.c.verify new file mode 100644 index 000000000..fe739f1fa --- /dev/null +++ b/tests/cn/failing_postcond.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: inc -- fail +tests/cn/failing_postcond.error.c:5:5: error: Unprovable constraint + return x + 1; + ^~~~~~~~~~~~~ +Constraint from tests/cn/failing_postcond.error.c:3:13: +/*@ ensures return < 2147483647i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__failing_postcond.error.c__inc.html diff --git a/tests/cn/failing_precond.error.c.verify b/tests/cn/failing_precond.error.c.verify new file mode 100644 index 000000000..d98e2153b --- /dev/null +++ b/tests/cn/failing_precond.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/failing_precond.error.c:2:18: error: Type error +/*@ requires x < 2147483647; @*/ + ^ +Expression '2147483647' has type 'integer'. +I expected it to have type 'i32' because of tests/cn/failing_precond.error.c:2:14: +/*@ requires x < 2147483647; @*/ + ^ diff --git a/tests/cn/forloop_with_decl.c.verify b/tests/cn/forloop_with_decl.c.verify new file mode 100644 index 000000000..b9ced8656 --- /dev/null +++ b/tests/cn/forloop_with_decl.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: for_with_decl -- pass diff --git a/tests/cn/from_bytes.error.c.verify b/tests/cn/from_bytes.error.c.verify new file mode 100644 index 000000000..aac42624f --- /dev/null +++ b/tests/cn/from_bytes.error.c.verify @@ -0,0 +1,11 @@ +return code: 1 +tests/cn/from_bytes.error.c:5:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Owned(p); @*/ + ^~~~~~~~ +tests/cn/from_bytes.error.c:6:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*@ from_bytes Alloc(p); @*/ // <-- proof fails here, but this is a no-op in runtime + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn/from_bytes.error.c:6:9: error: byte conversion only supports Owned/Block + /*@ from_bytes Alloc(p); @*/ // <-- proof fails here, but this is a no-op in runtime + ^~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/fun_addrs_cn_stmt.c.verify b/tests/cn/fun_addrs_cn_stmt.c.verify new file mode 100644 index 000000000..2822fb76c --- /dev/null +++ b/tests/cn/fun_addrs_cn_stmt.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: g -- pass +[2/2]: f -- pass diff --git a/tests/cn/fun_ptr_extern.c.verify b/tests/cn/fun_ptr_extern.c.verify new file mode 100644 index 000000000..f89dd0f7f --- /dev/null +++ b/tests/cn/fun_ptr_extern.c.verify @@ -0,0 +1,5 @@ +return code: 0 +[1/4]: f1 -- pass +[2/4]: get_int_binop -- pass +[3/4]: call_site -- pass +[4/4]: main -- pass diff --git a/tests/cn/fun_ptr_known.c.verify b/tests/cn/fun_ptr_known.c.verify new file mode 100644 index 000000000..d966d7146 --- /dev/null +++ b/tests/cn/fun_ptr_known.c.verify @@ -0,0 +1,5 @@ +return code: 0 +[1/4]: f1 -- pass +[2/4]: f2 -- pass +[3/4]: f3 -- pass +[4/4]: main -- pass diff --git a/tests/cn/fun_ptr_three_opts.c.verify b/tests/cn/fun_ptr_three_opts.c.verify new file mode 100644 index 000000000..dcfcf08ca --- /dev/null +++ b/tests/cn/fun_ptr_three_opts.c.verify @@ -0,0 +1,7 @@ +return code: 0 +[1/6]: f1 -- pass +[2/6]: f2 -- pass +[3/6]: f3 -- pass +[4/6]: get_int_binop -- pass +[5/6]: call_site -- pass +[6/6]: main -- pass diff --git a/tests/cn/get_from_arr.c.verify b/tests/cn/get_from_arr.c.verify new file mode 100644 index 000000000..5aabc6bff --- /dev/null +++ b/tests/cn/get_from_arr.c.verify @@ -0,0 +1,14 @@ +return code: 0 +tests/cn/get_from_arr.c:7:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. +/*@ requires take IA = each (i32 j; 0i32 <= j && j < 10i32) + ^ +tests/cn/get_from_arr.c:9:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. +/*@ ensures take IA2 = each (i32 j; 0i32 <= j && j < 10i32) + ^ +tests/cn/get_from_arr.c:14:28: warning: 'extract' expects a 'u64', but '4'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 4i32; @*/ + ^ +tests/cn/get_from_arr.c:15:7: warning: nothing instantiated + /*@ instantiate good, 4i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: get_from_arr -- pass diff --git a/tests/cn/get_from_array.c.verify b/tests/cn/get_from_array.c.verify new file mode 100644 index 000000000..f9411a18f --- /dev/null +++ b/tests/cn/get_from_array.c.verify @@ -0,0 +1,15 @@ +return code: 0 +tests/cn/get_from_array.c:16:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function global_array_width; @*/ + ^~~~~~~~~~~ +tests/cn/get_from_array.c:24:8: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. + take Arr = each (i32 i; 0i32 <= i && i < global_array_width ()) + ^ +tests/cn/get_from_array.c:40:28: warning: 'extract' expects a 'u64', but '(i32)idx' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, ((i32) idx); @*/ + ^~~~~~~~~ +[1/2]: get_global_array_width_for_cn -- pass +tests/cn/get_from_array.c:41:7: warning: nothing instantiated + /*@ instantiate good, ((i32) idx); @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[2/2]: set_a_pointer -- pass diff --git a/tests/cn/ghost_pointer_to_bitvec_cast.c.verify b/tests/cn/ghost_pointer_to_bitvec_cast.c.verify new file mode 100644 index 000000000..f1de7d51d --- /dev/null +++ b/tests/cn/ghost_pointer_to_bitvec_cast.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: test_cast_loc_to_various -- pass +[2/2]: main -- pass diff --git a/tests/cn/gnu_case_ranges.c.verify b/tests/cn/gnu_case_ranges.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/gnu_case_ranges.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/gnu_choose.c.verify b/tests/cn/gnu_choose.c.verify new file mode 100644 index 000000000..e51cabdb4 --- /dev/null +++ b/tests/cn/gnu_choose.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: f -- pass +[2/3]: g -- pass +[3/3]: main -- pass diff --git a/tests/cn/gnu_ctz.c.verify b/tests/cn/gnu_ctz.c.verify new file mode 100644 index 000000000..a0ab8fde2 --- /dev/null +++ b/tests/cn/gnu_ctz.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: ctz -- pass +[2/2]: main -- pass diff --git a/tests/cn/gnu_ffs.c.verify b/tests/cn/gnu_ffs.c.verify new file mode 100644 index 000000000..6a005aa32 --- /dev/null +++ b/tests/cn/gnu_ffs.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: ffs -- pass +[2/2]: main -- pass diff --git a/tests/cn/gnu_types_compatible.c.verify b/tests/cn/gnu_types_compatible.c.verify new file mode 100644 index 000000000..e51cabdb4 --- /dev/null +++ b/tests/cn/gnu_types_compatible.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: f -- pass +[2/3]: g -- pass +[3/3]: main -- pass diff --git a/tests/cn/has_alloc_id.c.verify b/tests/cn/has_alloc_id.c.verify new file mode 100644 index 000000000..e51cabdb4 --- /dev/null +++ b/tests/cn/has_alloc_id.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: f -- pass +[2/3]: g -- pass +[3/3]: main -- pass diff --git a/tests/cn/has_alloc_id.error.c.verify b/tests/cn/has_alloc_id.error.c.verify new file mode 100644 index 000000000..288d8c3c6 --- /dev/null +++ b/tests/cn/has_alloc_id.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/has_alloc_id.error.c:9:30: error: Type error + /*@ assert (has_alloc_id(0u64)); @*/ + ^ +Expression '0'u64' has type 'u64'. +I expected it to have type 'pointer' because of tests/cn/has_alloc_id.error.c:9:17: + /*@ assert (has_alloc_id(0u64)); @*/ + ~~~~~~~~~~~~^~~~~~ diff --git a/tests/cn/has_alloc_id_ptr_eq.error.c.verify b/tests/cn/has_alloc_id_ptr_eq.error.c.verify new file mode 100644 index 000000000..38cb5eff8 --- /dev/null +++ b/tests/cn/has_alloc_id_ptr_eq.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/has_alloc_id_ptr_eq.error.c:10:5: error: Unprovable constraint + return p == q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/has_alloc_id_ptr_eq.error.c:7:5: + return == 1i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__has_alloc_id_ptr_eq.error.c__f.html diff --git a/tests/cn/has_alloc_id_ptr_eq2.error.c.verify b/tests/cn/has_alloc_id_ptr_eq2.error.c.verify new file mode 100644 index 000000000..351dcefa7 --- /dev/null +++ b/tests/cn/has_alloc_id_ptr_eq2.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/has_alloc_id_ptr_eq2.error.c:10:5: error: Unprovable constraint + return p == q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/has_alloc_id_ptr_eq2.error.c:7:5: + return == 0i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__has_alloc_id_ptr_eq2.error.c__f.html diff --git a/tests/cn/has_alloc_id_ptr_neq.c.verify b/tests/cn/has_alloc_id_ptr_neq.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/has_alloc_id_ptr_neq.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/has_alloc_id_ptr_neq.error.c.verify b/tests/cn/has_alloc_id_ptr_neq.error.c.verify new file mode 100644 index 000000000..94131267d --- /dev/null +++ b/tests/cn/has_alloc_id_ptr_neq.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/has_alloc_id_ptr_neq.error.c:11:5: error: Unprovable constraint + return p != q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/has_alloc_id_ptr_neq.error.c:8:5: + return == 0i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__has_alloc_id_ptr_neq.error.c__f.html diff --git a/tests/cn/has_alloc_id_shift.c.verify b/tests/cn/has_alloc_id_shift.c.verify new file mode 100644 index 000000000..32acd623f --- /dev/null +++ b/tests/cn/has_alloc_id_shift.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: array_shift -- pass +[2/3]: member_shift -- pass +[3/3]: main -- pass diff --git a/tests/cn/implies.c.verify b/tests/cn/implies.c.verify new file mode 100644 index 000000000..02dc41acf --- /dev/null +++ b/tests/cn/implies.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: identity -- pass diff --git a/tests/cn/implies2.error.c.verify b/tests/cn/implies2.error.c.verify new file mode 100644 index 000000000..448c8e393 --- /dev/null +++ b/tests/cn/implies2.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: identity -- fail +tests/cn/implies2.error.c:4:9: error: Unprovable constraint + /*@ assert((x == 0i32) implies (y == 1i32));@*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constraint from tests/cn/implies2.error.c:4:9: + /*@ assert((x == 0i32) implies (y == 1i32));@*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__implies2.error.c__identity.html diff --git a/tests/cn/implies3.error.c.verify b/tests/cn/implies3.error.c.verify new file mode 100644 index 000000000..6958a7939 --- /dev/null +++ b/tests/cn/implies3.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/implies3.error.c:1:1: error: function makes inconsistent assumptions +int foo () +~~~~^~~~~~ +State file: file:///tmp/state__implies3.error.c.html diff --git a/tests/cn/implies_associativity.c.verify b/tests/cn/implies_associativity.c.verify new file mode 100644 index 000000000..7213715e9 --- /dev/null +++ b/tests/cn/implies_associativity.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: foo -- pass diff --git a/tests/cn/implies_precedence.c.verify b/tests/cn/implies_precedence.c.verify new file mode 100644 index 000000000..7213715e9 --- /dev/null +++ b/tests/cn/implies_precedence.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: foo -- pass diff --git a/tests/cn/incomplete_match.error.c.verify b/tests/cn/incomplete_match.error.c.verify new file mode 100644 index 000000000..96ce317d7 --- /dev/null +++ b/tests/cn/incomplete_match.error.c.verify @@ -0,0 +1,4 @@ +return code: 1 +tests/cn/incomplete_match.error.c:9:3: error: Incomplete pattern + match t { + ^~~~~~~~~ diff --git a/tests/cn/inconsistent.error.c.verify b/tests/cn/inconsistent.error.c.verify new file mode 100644 index 000000000..29136eb38 --- /dev/null +++ b/tests/cn/inconsistent.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/inconsistent.error.c:1:1: error: function makes inconsistent assumptions +void f() +~~~~~^~~ +State file: file:///tmp/state__inconsistent.error.c.html diff --git a/tests/cn/inconsistent2.error.c.verify b/tests/cn/inconsistent2.error.c.verify new file mode 100644 index 000000000..125c67455 --- /dev/null +++ b/tests/cn/inconsistent2.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/inconsistent2.error.c:9:19: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. +/*@ requires take f1 = each(i32 i; 0i32 <= i && i <= 0i32) { False(p + i, i) }; + ^ +tests/cn/inconsistent2.error.c:8:1: error: return type makes inconsistent assumptions +void f (int *p) +~~~~~^~~~~~~~~~ +State file: file:///tmp/state__inconsistent2.error.c.html diff --git a/tests/cn/inconsistent3.error.c.verify b/tests/cn/inconsistent3.error.c.verify new file mode 100644 index 000000000..b576af0bd --- /dev/null +++ b/tests/cn/inconsistent3.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/inconsistent3.error.c:1:1: error: return type makes inconsistent assumptions +void f (int *p) +~~~~~^~~~~~~~~~ +State file: file:///tmp/state__inconsistent3.error.c.html diff --git a/tests/cn/increments.c.verify b/tests/cn/increments.c.verify new file mode 100644 index 000000000..6da074677 --- /dev/null +++ b/tests/cn/increments.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: direct -- pass +[2/2]: indirect -- pass diff --git a/tests/cn/int_to_ptr.c.verify b/tests/cn/int_to_ptr.c.verify new file mode 100644 index 000000000..8dfd8221e --- /dev/null +++ b/tests/cn/int_to_ptr.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: cast -- pass +[2/2]: main -- pass diff --git a/tests/cn/int_to_ptr.error.c.verify b/tests/cn/int_to_ptr.error.c.verify new file mode 100644 index 000000000..d93ed004a --- /dev/null +++ b/tests/cn/int_to_ptr.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: cast -- pass +[2/2]: main -- fail +tests/cn/int_to_ptr.error.c:16:12: error: Missing resource for reading + return *p == 0; + ^~ +Resource needed: Owned(call_cast0.return) +State file: file:///tmp/state__int_to_ptr.error.c__main.html diff --git a/tests/cn/left_shift_const.c.verify b/tests/cn/left_shift_const.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/left_shift_const.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/lexer_hack_parse.error.c.verify b/tests/cn/lexer_hack_parse.error.c.verify new file mode 100644 index 000000000..e0b0ddb05 --- /dev/null +++ b/tests/cn/lexer_hack_parse.error.c.verify @@ -0,0 +1,5 @@ +return code: 2 +tests/cn/lexer_hack_parse.error.c:14:13: error: unexpected token after '>' and before 'Cons' +parsing "match_case": seen "pattern EQ GT", expecting "LBRACE expr RBRACE" + Cons {} + ^~~~ diff --git a/tests/cn/list_literal_type.error.c.verify b/tests/cn/list_literal_type.error.c.verify new file mode 100644 index 000000000..61ce79877 --- /dev/null +++ b/tests/cn/list_literal_type.error.c.verify @@ -0,0 +1,5 @@ +return code: 2 +tests/cn/list_literal_type.error.c:3:15: error: unexpected token after 'list' and before '<' +Please add error message for state 1869 to parsers/c/c_parser_error.messages +function (list) nonempty_list() { + ^ diff --git a/tests/cn/list_rev01.c.verify b/tests/cn/list_rev01.c.verify new file mode 100644 index 000000000..0c40cadc3 --- /dev/null +++ b/tests/cn/list_rev01.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: rev_list -- pass diff --git a/tests/cn/magic_comment_not_closed.c.verify b/tests/cn/magic_comment_not_closed.c.verify new file mode 100644 index 000000000..344e1e068 --- /dev/null +++ b/tests/cn/magic_comment_not_closed.c.verify @@ -0,0 +1,5 @@ +return code: 0 +tests/cn/magic_comment_not_closed.c:1:19: warning: magic comment syntax at open but not close +/*@ assert(true); */ + ^ +[1/1]: main -- pass diff --git a/tests/cn/map_set.error.c.verify b/tests/cn/map_set.error.c.verify new file mode 100644 index 000000000..cdb400495 --- /dev/null +++ b/tests/cn/map_set.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/map_set.error.c:3:24: error: the type name `bool' is not declared +function (map) write_to_012(integer foo, map my_map) { + ^ diff --git a/tests/cn/mask_ptr.c.verify b/tests/cn/mask_ptr.c.verify new file mode 100644 index 000000000..297a9e53c --- /dev/null +++ b/tests/cn/mask_ptr.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: foo_integer -- pass +[2/2]: foo -- pass diff --git a/tests/cn/match.c.verify b/tests/cn/match.c.verify new file mode 100644 index 000000000..941d1e7b0 --- /dev/null +++ b/tests/cn/match.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: check_foo -- pass +[2/2]: main -- pass diff --git a/tests/cn/max_min_consts.c.verify b/tests/cn/max_min_consts.c.verify new file mode 100644 index 000000000..164a4a72d --- /dev/null +++ b/tests/cn/max_min_consts.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: check_cn_max_min_consts -- pass +[2/2]: main -- pass diff --git a/tests/cn/max_pipes.error.c.verify b/tests/cn/max_pipes.error.c.verify new file mode 100644 index 000000000..2dcac92d8 --- /dev/null +++ b/tests/cn/max_pipes.error.c.verify @@ -0,0 +1,45 @@ +return code: 1 +[1/11]: f_22 -- pass +[2/11]: f_32 -- fail +[3/11]: _OSSwapInt16 -- fail +[4/11]: _OSSwapInt32 -- fail +[5/11]: OSReadSwapInt16 -- fail +[6/11]: OSReadSwapInt32 -- fail +[7/11]: OSReadSwapInt64 -- fail +[8/11]: f_61 -- pass +[9/11]: f_73 -- fail +[10/11]: f_91 -- pass +[11/11]: f_103 -- pass +tests/cn/max_pipes.error.c:37:1: error: Undefined behaviour +static uint8_t f_32() { +~~~~~~~~~~~~~~~^~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c__f_32.html +tests/cn/max_pipes.error.c:58:1: error: Undefined behaviour +uint16_t _OSSwapInt16(_data) {} +~~~~~~~~~^~~~~~~~~~~~~~~~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c___OSSwapInt16.html +tests/cn/max_pipes.error.c:59:40: error: Unknown function 'bswap32_proxy' +uint32_t _OSSwapInt32(_data) { _data = __builtin_bswap32(_data); } + ^~~~~~~~~~~~~~~~~ +tests/cn/max_pipes.error.c:63:1: error: Undefined behaviour +uint16_t OSReadSwapInt16(_offset) {} +~~~~~~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c__OSReadSwapInt16.html +tests/cn/max_pipes.error.c:64:1: error: Undefined behaviour +uint32_t OSReadSwapInt32() {} +~~~~~~~~~^~~~~~~~~~~~~~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c__OSReadSwapInt32.html +tests/cn/max_pipes.error.c:65:1: error: Undefined behaviour +uint64_t OSReadSwapInt64() {} +~~~~~~~~~^~~~~~~~~~~~~~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c__OSReadSwapInt64.html +tests/cn/max_pipes.error.c:82:17: error: `&(&&d_47[(u64)0'i32])[(u64)O_c1]` out of bounds + switch (d_47[c][s]) { + ^~~~~~~ +(UB missing short message): UB_CERB004_unspecified__pointer_add +State file: file:///tmp/state__max_pipes.error.c__f_73.html diff --git a/tests/cn/memcpy.c.verify b/tests/cn/memcpy.c.verify new file mode 100644 index 000000000..5208f19ec --- /dev/null +++ b/tests/cn/memcpy.c.verify @@ -0,0 +1,32 @@ +return code: 0 +tests/cn/memcpy.c:3:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. +/*@ requires take dstStart = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:5:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take srcStart = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:7:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + ensures take dstEnd = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:9:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take srcEnd = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:17:16: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + /*@ inv take dstInv = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:19:16: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take srcInv = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:17:16: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + /*@ inv take dstInv = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:19:16: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take srcInv = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:28:30: warning: 'extract' expects a 'u64', but '(i32)read_&i0' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, (i32)i; @*/ + ^~~~~~ +tests/cn/memcpy.c:29:9: warning: nothing instantiated + /*@ instantiate good, (i32)i; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: naive_memcpy -- pass diff --git a/tests/cn/mergesort.c.verify b/tests/cn/mergesort.c.verify new file mode 100644 index 000000000..5278ce591 --- /dev/null +++ b/tests/cn/mergesort.c.verify @@ -0,0 +1,5 @@ +return code: 0 +[1/4]: split -- pass +[2/4]: merge -- pass +[3/4]: naive_mergesort -- pass +[4/4]: prove_merge_sorted -- pass diff --git a/tests/cn/mergesort_alt.c.verify b/tests/cn/mergesort_alt.c.verify new file mode 100644 index 000000000..a0551bf04 --- /dev/null +++ b/tests/cn/mergesort_alt.c.verify @@ -0,0 +1,5 @@ +return code: 0 +[1/4]: split -- pass +[2/4]: prove_merge_sorted -- pass +[3/4]: merge -- pass +[4/4]: naive_mergesort -- pass diff --git a/tests/cn/merging_arrays.error.c.verify b/tests/cn/merging_arrays.error.c.verify new file mode 100644 index 000000000..35629d46a --- /dev/null +++ b/tests/cn/merging_arrays.error.c.verify @@ -0,0 +1,11 @@ +return code: 1 +[1/3]: half -- pass +[2/3]: whole -- pass +[3/3]: main -- fail +tests/cn/merging_arrays.error.c:25:5: error: Cannot satisfy request for resource for calling function whole. It requires merging multiple arrays. + whole(a); + ^~~~~~~~ +Resource needed: each(u64 i; 0'u64 <= i && i < 10'u64) +{Owned(&a + i * 4'u64)} + tests/cn/merging_arrays.error.c:14:10: (arg X) +State file: file:///tmp/state__merging_arrays.error.c__main.html diff --git a/tests/cn/missing_resource.error.c.verify b/tests/cn/missing_resource.error.c.verify new file mode 100644 index 000000000..a4434ee71 --- /dev/null +++ b/tests/cn/missing_resource.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/missing_resource.error.c:11:3: error: Missing resource for returning + return x; + ^~~~~~~~~ +Resource needed: Owned(p) + tests/cn/missing_resource.error.c:9:18: (arg Resource_From_Nothing) +State file: file:///tmp/state__missing_resource.error.c__f.html diff --git a/tests/cn/missing_resource_indirect.error.c.verify b/tests/cn/missing_resource_indirect.error.c.verify new file mode 100644 index 000000000..fb819e684 --- /dev/null +++ b/tests/cn/missing_resource_indirect.error.c.verify @@ -0,0 +1,10 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/missing_resource_indirect.error.c:18:3: error: Missing resource for returning + return x; + ^~~~~~~~~ +Resource needed: Owned_Wrapper(p) + tests/cn/missing_resource_indirect.error.c:16:18: (arg Resource_From_Nothing) + which requires: Owned(p) + tests/cn/missing_resource_indirect.error.c:7:8: (arg I) +State file: file:///tmp/state__missing_resource_indirect.error.c__f.html diff --git a/tests/cn/mod.c.verify b/tests/cn/mod.c.verify new file mode 100644 index 000000000..15f36f592 --- /dev/null +++ b/tests/cn/mod.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: mod -- pass diff --git a/tests/cn/mod_by_0.error.c.verify b/tests/cn/mod_by_0.error.c.verify new file mode 100644 index 000000000..015dcad77 --- /dev/null +++ b/tests/cn/mod_by_0.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: mod -- fail +tests/cn/mod_by_0.error.c:6:12: error: Undefined behaviour + return x % y; + ~~^~~ +the value of the second operand of a '%' operator is zero (§6.5.5#5, sentence 2) +State file: file:///tmp/state__mod_by_0.error.c__mod.html diff --git a/tests/cn/mod_casting.c.verify b/tests/cn/mod_casting.c.verify new file mode 100644 index 000000000..15f36f592 --- /dev/null +++ b/tests/cn/mod_casting.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: mod -- pass diff --git a/tests/cn/mod_precedence.c.verify b/tests/cn/mod_precedence.c.verify new file mode 100644 index 000000000..07368938c --- /dev/null +++ b/tests/cn/mod_precedence.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: mod_no_parenthesis -- pass +[2/3]: multiply_then_mod -- pass +[3/3]: divide_multiply_mod_add_subtract -- pass diff --git a/tests/cn/mod_return_sign.error.c.verify b/tests/cn/mod_return_sign.error.c.verify new file mode 100644 index 000000000..5df0d50f0 --- /dev/null +++ b/tests/cn/mod_return_sign.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/mod_return_sign.error.c:7:27: error: Type error + ensures return == x % y; @*/ + ^ +Expression 'y' has type 'u32'. +I expected it to have type 'i32' because of tests/cn/mod_return_sign.error.c:7:23: + ensures return == x % y; @*/ + ^ diff --git a/tests/cn/mod_return_size.error.c.verify b/tests/cn/mod_return_size.error.c.verify new file mode 100644 index 000000000..f4f9fd2c4 --- /dev/null +++ b/tests/cn/mod_return_size.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: different_size -- fail +tests/cn/mod_return_size.error.c:9:5: error: Unprovable constraint + return x % y; + ^~~~~~~~~~~~~ +Constraint from tests/cn/mod_return_size.error.c:7:13: + ensures return == x % (i32)y; @*/ + ^~~~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__mod_return_size.error.c__different_size.html diff --git a/tests/cn/mod_with_constants.c.verify b/tests/cn/mod_with_constants.c.verify new file mode 100644 index 000000000..d1c740f4d --- /dev/null +++ b/tests/cn/mod_with_constants.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: x_mod_three -- pass +[2/3]: x_mod_neg_three -- pass +[3/3]: mod_first_operand_neg -- pass diff --git a/tests/cn/multifile/f.c.verify b/tests/cn/multifile/f.c.verify new file mode 100644 index 000000000..a330c9e78 --- /dev/null +++ b/tests/cn/multifile/f.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: test_c -- pass diff --git a/tests/cn/multifile/g.c.verify b/tests/cn/multifile/g.c.verify new file mode 100644 index 000000000..f5671beb8 --- /dev/null +++ b/tests/cn/multifile/g.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: g -- pass diff --git a/tests/cn/mutual_rec/build.sh b/tests/cn/mutual_rec/build.sh deleted file mode 100644 index c900c3c28..000000000 --- a/tests/cn/mutual_rec/build.sh +++ /dev/null @@ -1,6 +0,0 @@ - -set -ex -cn verify mutual_rec.c -cn verify --lemmata coq_lemmas/theories/Gen_Spec.v mutual_rec.c -make -C coq_lemmas - diff --git a/tests/cn/mutual_rec/coq_lemmas/Makefile b/tests/cn/mutual_rec/coq_lemmas/Makefile index b248d3425..c343861ff 100644 --- a/tests/cn/mutual_rec/coq_lemmas/Makefile +++ b/tests/cn/mutual_rec/coq_lemmas/Makefile @@ -1,8 +1,4 @@ - - - all: coq_makefile -f _CoqProject -o Makefile.coq - cn verify --lemmata theories/Gen_Spec.v ../mutual_rec.c + cn verify ../mutual_rec2.c --lemmata theories/Gen_Spec.v &> /dev/null make -f Makefile.coq - diff --git a/tests/cn/mutual_rec/coq_lemmas/_CoqProject b/tests/cn/mutual_rec/coq_lemmas/_CoqProject index 012738ab4..30ef14952 100644 --- a/tests/cn/mutual_rec/coq_lemmas/_CoqProject +++ b/tests/cn/mutual_rec/coq_lemmas/_CoqProject @@ -1,9 +1,6 @@ - -Q theories CN_Lemmas theories/CN_Lib.v theories/Gen_Spec.v theories/Setup.v theories/Inst_Spec.v - - diff --git a/tests/cn/mutual_rec/mutual_rec1.c.verify b/tests/cn/mutual_rec/mutual_rec1.c.verify new file mode 100644 index 000000000..f4787dbdf --- /dev/null +++ b/tests/cn/mutual_rec/mutual_rec1.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: walk_b_tree -- pass +[2/2]: walk_a_tree -- pass diff --git a/tests/cn/mutual_rec/mutual_rec2.c.verify b/tests/cn/mutual_rec/mutual_rec2.c.verify new file mode 100644 index 000000000..fbe1952af --- /dev/null +++ b/tests/cn/mutual_rec/mutual_rec2.c.verify @@ -0,0 +1,10 @@ +return code: 0 +[1/9]: a_tree_keys_node_lemma -- pass +[2/9]: b_tree_keys_node_lemma -- pass +[3/9]: a_tree_keys_node_concat_inc_lemma -- pass +[4/9]: a_tree_keys_node_concat_cons_inc_lemma -- pass +[5/9]: b_tree_keys_node_merge_inc_lemma -- pass +[6/9]: b_tree_keys_node_merge_flip_lemma -- pass +[7/9]: b_tree_keys_node_inc_inc_double_lemma -- pass +[8/9]: inc_b_tree -- pass +[9/9]: inc_a_tree -- pass diff --git a/tests/cn/mutual_rec/mutual_rec3.c.verify b/tests/cn/mutual_rec/mutual_rec3.c.verify new file mode 100644 index 000000000..a5b15c2d0 --- /dev/null +++ b/tests/cn/mutual_rec/mutual_rec3.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: predef_a_tree -- pass diff --git a/tests/cn/null_to_int.c.verify b/tests/cn/null_to_int.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/null_to_int.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/ownership_at_negative_index.c.verify b/tests/cn/ownership_at_negative_index.c.verify new file mode 100644 index 000000000..8096aa2e7 --- /dev/null +++ b/tests/cn/ownership_at_negative_index.c.verify @@ -0,0 +1,11 @@ +return code: 0 +tests/cn/ownership_at_negative_index.c:2:19: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. +/*@ requires take vs = each(i32 i; i == -1i32) { Owned(array_shift(p,i)) }; + ^ +tests/cn/ownership_at_negative_index.c:3:18: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. + ensures take ws = each(i32 i; i == -1i32) { Owned(array_shift(p,i)) }; + ^ +tests/cn/ownership_at_negative_index.c:6:27: warning: 'extract' expects a 'u64', but '-1'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, -1i32; @*/ + ^~~~~ +[1/1]: f -- pass diff --git a/tests/cn/partial_init_bytes.error.c.verify b/tests/cn/partial_init_bytes.error.c.verify new file mode 100644 index 000000000..5a041cf85 --- /dev/null +++ b/tests/cn/partial_init_bytes.error.c.verify @@ -0,0 +1,16 @@ +return code: 1 +tests/cn/partial_init_bytes.error.c:5:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Block(p); @*/ + ^~~~~~~~ +tests/cn/partial_init_bytes.error.c:9:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*@ from_bytes Owned(p); @*/ + ^~~~~~~~~~ +tests/cn/partial_init_bytes.error.c:7:9: warning: extract: index added, no resources (yet) extracted. + /*@ extract Block, 2u64; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: main -- fail +tests/cn/partial_init_bytes.error.c:8:5: error: Missing resource for writing + p_char[2] = 0xff; + ~~~~~~~~~~^~~~~~ +Resource needed: Block(&&x[(u64)2'i32]) +State file: file:///tmp/state__partial_init_bytes.error.c__main.html diff --git a/tests/cn/pointer_to_char_cast.c.verify b/tests/cn/pointer_to_char_cast.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/pointer_to_char_cast.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/pointer_to_char_cast.error.c.verify b/tests/cn/pointer_to_char_cast.error.c.verify new file mode 100644 index 000000000..e685c4f10 --- /dev/null +++ b/tests/cn/pointer_to_char_cast.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/pointer_to_char_cast.error.c:5:5: error: integer value not representable at type char + (char)&x; + ^~~~~~~~ +Value: &x +State file: file:///tmp/state__pointer_to_char_cast.error.c__f.html diff --git a/tests/cn/pointer_to_int_cast.error.c.verify b/tests/cn/pointer_to_int_cast.error.c.verify new file mode 100644 index 000000000..a6bd3da7a --- /dev/null +++ b/tests/cn/pointer_to_int_cast.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/pointer_to_int_cast.error.c:3:3: error: integer value not representable at type signed int + (int)&x; + ^~~~~~~ +Value: &x +State file: file:///tmp/state__pointer_to_int_cast.error.c__f.html diff --git a/tests/cn/pointer_to_intptr_t_cast.c.verify b/tests/cn/pointer_to_intptr_t_cast.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/pointer_to_intptr_t_cast.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/pointer_to_uintptr_t_cast.c.verify b/tests/cn/pointer_to_uintptr_t_cast.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/pointer_to_uintptr_t_cast.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/pointer_to_unsigned_int_cast.error.c.verify b/tests/cn/pointer_to_unsigned_int_cast.error.c.verify new file mode 100644 index 000000000..e4ba47f4f --- /dev/null +++ b/tests/cn/pointer_to_unsigned_int_cast.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/pointer_to_unsigned_int_cast.error.c:3:3: error: integer value not representable at type unsigned int + (unsigned int)&x; + ^~~~~~~~~~~~~~~~ +Value: &x +State file: file:///tmp/state__pointer_to_unsigned_int_cast.error.c__f.html diff --git a/tests/cn/pred_def01.c.verify b/tests/cn/pred_def01.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/pred_def01.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/pred_def02.c.verify b/tests/cn/pred_def02.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/pred_def02.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/pred_def03.error.c.verify b/tests/cn/pred_def03.error.c.verify new file mode 100644 index 000000000..da77a0059 --- /dev/null +++ b/tests/cn/pred_def03.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/pred_def03.error.c:14:13: error: Unexpected member wrong + assert( tail.wrong ) ; + ~~~~^~~~~~ +the struct only has members len diff --git a/tests/cn/pred_def04.c.verify b/tests/cn/pred_def04.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/pred_def04.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/previously_inconsistent_assumptions1.c.verify b/tests/cn/previously_inconsistent_assumptions1.c.verify new file mode 100644 index 000000000..e1522bb41 --- /dev/null +++ b/tests/cn/previously_inconsistent_assumptions1.c.verify @@ -0,0 +1 @@ +return code: 0 diff --git a/tests/cn/previously_inconsistent_assumptions2.c.verify b/tests/cn/previously_inconsistent_assumptions2.c.verify new file mode 100644 index 000000000..6e96ac104 --- /dev/null +++ b/tests/cn/previously_inconsistent_assumptions2.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: a -- pass diff --git a/tests/cn/ptr_diff.c.verify b/tests/cn/ptr_diff.c.verify new file mode 100644 index 000000000..d9cd1b4b3 --- /dev/null +++ b/tests/cn/ptr_diff.c.verify @@ -0,0 +1,6 @@ +return code: 0 +[1/5]: live_owned_footprint -- pass +[2/5]: live_owned_both -- pass +[3/5]: live_owned_one -- pass +[4/5]: live_alloc -- pass +[5/5]: main -- pass diff --git a/tests/cn/ptr_diff.error.c.verify b/tests/cn/ptr_diff.error.c.verify new file mode 100644 index 000000000..258b18d56 --- /dev/null +++ b/tests/cn/ptr_diff.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: live_owned_footprint -- fail +[2/2]: main -- pass +tests/cn/ptr_diff.error.c:13:10: error: Pointer `q` needs to be live for pointer difference + return q - p; + ~~^~~ +Need an Alloc or Owned in context with same allocation id +State file: file:///tmp/state__ptr_diff.error.c__live_owned_footprint.html diff --git a/tests/cn/ptr_diff2.c.verify b/tests/cn/ptr_diff2.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/ptr_diff2.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/ptr_diff2.error.c.verify b/tests/cn/ptr_diff2.error.c.verify new file mode 100644 index 000000000..3ff6082c7 --- /dev/null +++ b/tests/cn/ptr_diff2.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/ptr_diff2.error.c:4:10: error: Pointer `p` needs allocation ID + return p - 1; + ~~^~~ +(UB missing short message): UB_CERB004_unspecified__pointer_add +State file: file:///tmp/state__ptr_diff2.error.c__f.html diff --git a/tests/cn/ptr_relop.c.verify b/tests/cn/ptr_relop.c.verify new file mode 100644 index 000000000..d9cd1b4b3 --- /dev/null +++ b/tests/cn/ptr_relop.c.verify @@ -0,0 +1,6 @@ +return code: 0 +[1/5]: live_owned_footprint -- pass +[2/5]: live_owned_both -- pass +[3/5]: live_owned_one -- pass +[4/5]: live_alloc -- pass +[5/5]: main -- pass diff --git a/tests/cn/ptr_relop.error.c.verify b/tests/cn/ptr_relop.error.c.verify new file mode 100644 index 000000000..25a7777a1 --- /dev/null +++ b/tests/cn/ptr_relop.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: live_owned_footprint -- fail +[2/2]: main -- pass +tests/cn/ptr_relop.error.c:13:10: error: Pointer `q` needs to be live for pointer comparison + return q > p; + ~~^~~ +Need an Alloc or Owned in context with same allocation id +State file: file:///tmp/state__ptr_relop.error.c__live_owned_footprint.html diff --git a/tests/cn/record1.c.verify b/tests/cn/record1.c.verify new file mode 100644 index 000000000..3bd78b098 --- /dev/null +++ b/tests/cn/record1.c.verify @@ -0,0 +1,11 @@ +return code: 0 +tests/cn/record1.c:13:18: warning: Treating exponentiation 'power(2'i32 + , 31'i32 /* 0x1f */)' as uninterpreted. +/*@ requires x < power(2i32, 31i32) - 1i32; + ~~~~~^~~~~~~~~~~~~ +tests/cn/record1.c:14:18: warning: Treating exponentiation 'power(2'i32 + , 31'i32 /* 0x1f */)' as uninterpreted. + requires y < power(2i32, 31i32) - 1i32; @*/ + ~~~~~^~~~~~~~~~~~~ +[1/2]: incr_one -- pass +[2/2]: decr_one -- pass diff --git a/tests/cn/redundant_pattern.error.c.verify b/tests/cn/redundant_pattern.error.c.verify new file mode 100644 index 000000000..8ea88e37f --- /dev/null +++ b/tests/cn/redundant_pattern.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/redundant_pattern.error.c:12:9: error: Redundant pattern + Cons { head : head , tail : tail } => { head + sum(tail) } + ~~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +covered by previous variable at tests/cn/redundant_pattern.error.c:11:9: + Nil => { 0 } + ^ +If this is meant to be an nullary constructor, write `Nil {}` instead diff --git a/tests/cn/reverse.c.verify b/tests/cn/reverse.c.verify new file mode 100644 index 000000000..57ed23668 --- /dev/null +++ b/tests/cn/reverse.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: reverse -- pass diff --git a/tests/cn/reverse.error.c.verify b/tests/cn/reverse.error.c.verify new file mode 100644 index 000000000..3689e7f3e --- /dev/null +++ b/tests/cn/reverse.error.c.verify @@ -0,0 +1,17 @@ +return code: 1 +[1/2]: reverse -- fail +[2/2]: main -- fail +tests/cn/reverse.error.c:106:7: error: Unprovable constraint + return cur; + ^~~~~~~~~~~ +Constraint from tests/cn/reverse.error.c:89:14: + L_ == rev(L); + ^~~~~~~~~~~~~ +State file: file:///tmp/state__reverse.error.c__reverse.html +tests/cn/reverse.error.c:124:3: error: Missing resource for de-allocating + return 0; + ^~~~~~~~~ +Resource needed: Block(&n3) + which requires: Block(&&n3->head) + other location (Cn__ResourceInference.General.predicate_request) (arg head) +State file: file:///tmp/state__reverse.error.c__main.html diff --git a/tests/cn/shift_diff_sz.c.verify b/tests/cn/shift_diff_sz.c.verify new file mode 100644 index 000000000..f865bbcda --- /dev/null +++ b/tests/cn/shift_diff_sz.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: test_shift_sizes -- pass +[2/2]: main -- pass diff --git a/tests/cn/simple_loop.c.verify b/tests/cn/simple_loop.c.verify new file mode 100644 index 000000000..f0bb8b696 --- /dev/null +++ b/tests/cn/simple_loop.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: simple_loop -- pass +[2/2]: main -- pass diff --git a/tests/cn/simplify_add_0.c.verify b/tests/cn/simplify_add_0.c.verify new file mode 100644 index 000000000..6288ba5e5 --- /dev/null +++ b/tests/cn/simplify_add_0.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: left_zero -- pass +[2/3]: right_zero -- pass +[3/3]: main -- pass diff --git a/tests/cn/simplify_array_shift.c.verify b/tests/cn/simplify_array_shift.c.verify new file mode 100644 index 000000000..07204a9f9 --- /dev/null +++ b/tests/cn/simplify_array_shift.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: IntQueue_pop -- pass diff --git a/tests/cn/solver_crash.error.c.verify b/tests/cn/solver_crash.error.c.verify new file mode 100644 index 000000000..d7e361c26 --- /dev/null +++ b/tests/cn/solver_crash.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/solver_crash.error.c:13:10: error: Missing resource for reading + .y = str_inst.x + 3, + ~~~~~~~~^~ +Resource needed: Owned(&&str_inst->x) +State file: file:///tmp/state__solver_crash.error.c__f.html diff --git a/tests/cn/spec_after_curly_brace.error.c.verify b/tests/cn/spec_after_curly_brace.error.c.verify new file mode 100644 index 000000000..e0c32af55 --- /dev/null +++ b/tests/cn/spec_after_curly_brace.error.c.verify @@ -0,0 +1,6 @@ +return code: 1 +tests/cn/spec_after_curly_brace.error.c:3:3: error: unexpected token before 'ensures' +You're inside a function - so I'm expecting a CN statement. +Hint: these start with 'extract', 'instantiate', 'split_case', 'assert', 'print', 'apply'. + ensures return == 0i32; @*/ + ^~~~~~~ diff --git a/tests/cn/spec_null_shift.c.verify b/tests/cn/spec_null_shift.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/spec_null_shift.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/spec_null_shift.error.c.verify b/tests/cn/spec_null_shift.error.c.verify new file mode 100644 index 000000000..1e361860d --- /dev/null +++ b/tests/cn/spec_null_shift.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/spec_null_shift.error.c:5:1: error: Unprovable constraint +void f(int *p, int *q) +~~~~~^~~~~~~~~~~~~~~~~ +Constraint from tests/cn/spec_null_shift.error.c:13:5: + ptr_eq(x, NULL) || ptr_eq(y, NULL) || (u64) x == 1u64 || (u64) y == 2u64; + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__spec_null_shift.error.c__f.html diff --git a/tests/cn/split_case.c.verify b/tests/cn/split_case.c.verify new file mode 100644 index 000000000..bff6a3a20 --- /dev/null +++ b/tests/cn/split_case.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: __list_del -- pass diff --git a/tests/cn/struct_updates.error.c.verify b/tests/cn/struct_updates.error.c.verify new file mode 100644 index 000000000..b7ae30a16 --- /dev/null +++ b/tests/cn/struct_updates.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/struct_updates.error.c:9:11: error: Type error + { x : 0 , y: 0 , ..bar } + ^ +Expression '0' has type 'integer'. +I expected it to have type 'i32' because of tests/cn/struct_updates.error.c:9:24: + { x : 0 , y: 0 , ..bar } + ^ diff --git a/tests/cn/struct_updates2.error.c.verify b/tests/cn/struct_updates2.error.c.verify new file mode 100644 index 000000000..4007fe333 --- /dev/null +++ b/tests/cn/struct_updates2.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/struct_updates2.error.c:12:24: error: Type error + { x : 0 , y: 0 , ..bar } + ^ +Expression 'bar' has type '{integer x,integer y}'. +I expected it to have type 'struct' because of tests/cn/struct_updates2.error.c:12:5: + { x : 0 , y: 0 , ..bar } + ^~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/swap.c.verify b/tests/cn/swap.c.verify new file mode 100644 index 000000000..ca8d58f18 --- /dev/null +++ b/tests/cn/swap.c.verify @@ -0,0 +1,20 @@ +return code: 0 +tests/cn/swap.c:4:9: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take pairStart = each (i32 j; 0i32 <= j && j < 2i32) {Owned(array_shift(pair, j))}; + ^ +tests/cn/swap.c:6:10: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take pairEnd = each (i32 j; 0i32 <= j && j < 2i32) {Owned(array_shift(pair, j))}; + ^ +tests/cn/swap.c:11:43: warning: 'extract' expects a 'u64', but '0'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 0i32; @*/ + ^ +tests/cn/swap.c:12:43: warning: 'extract' expects a 'u64', but '1'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 1i32; @*/ + ^ +tests/cn/swap.c:13:9: warning: nothing instantiated + /*@ instantiate good, 0i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tests/cn/swap.c:14:9: warning: nothing instantiated + /*@ instantiate good, 1i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: swap_pair -- pass diff --git a/tests/cn/swap_pair.c.verify b/tests/cn/swap_pair.c.verify new file mode 100644 index 000000000..e906bf33e --- /dev/null +++ b/tests/cn/swap_pair.c.verify @@ -0,0 +1,20 @@ +return code: 0 +tests/cn/swap_pair.c:4:10: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take pairStart = each (i32 j; 0i32 <= j && j < 2i32) {Owned(array_shift(pair_p, j))}; + ^ +tests/cn/swap_pair.c:6:10: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take pairEnd = each (i32 j; 0i32 <= j && j < 2i32) {Owned(array_shift(pair_p, j))}; + ^ +tests/cn/swap_pair.c:11:43: warning: 'extract' expects a 'u64', but '0'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 0i32; @*/ + ^ +tests/cn/swap_pair.c:13:43: warning: 'extract' expects a 'u64', but '1'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 1i32; @*/ + ^ +tests/cn/swap_pair.c:14:9: warning: nothing instantiated + /*@ instantiate good, 0i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tests/cn/swap_pair.c:16:9: warning: nothing instantiated + /*@ instantiate good, 1i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: swap_pair -- pass diff --git a/tests/cn/tag_defs.c.verify b/tests/cn/tag_defs.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/tag_defs.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/to_bytes.error.c.verify b/tests/cn/to_bytes.error.c.verify new file mode 100644 index 000000000..5e1d78e4f --- /dev/null +++ b/tests/cn/to_bytes.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/to_bytes.error.c:5:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Alloc(p); @*/ + ^~~~~~~~ +[1/1]: main -- fail +tests/cn/to_bytes.error.c:5:9: error: byte conversion only supports Owned/Block + /*@ to_bytes Alloc(p); @*/ + ^~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/to_from_bytes_block.c.verify b/tests/cn/to_from_bytes_block.c.verify new file mode 100644 index 000000000..35b31a153 --- /dev/null +++ b/tests/cn/to_from_bytes_block.c.verify @@ -0,0 +1,10 @@ +return code: 0 +tests/cn/to_from_bytes_block.c:9:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*@ from_bytes Block(p); @*/ + ^~~~~~~~~~ +tests/cn/to_from_bytes_block.c:20:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Block(p); @*/ + ^~~~~~~~ +[1/3]: from_bytes -- pass +[2/3]: to_bytes -- pass +[3/3]: main -- pass diff --git a/tests/cn/to_from_bytes_owned.c.verify b/tests/cn/to_from_bytes_owned.c.verify new file mode 100644 index 000000000..862824933 --- /dev/null +++ b/tests/cn/to_from_bytes_owned.c.verify @@ -0,0 +1,14 @@ +return code: 0 +tests/cn/to_from_bytes_owned.c:5:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Owned(p); @*/ + ^~~~~~~~ +tests/cn/to_from_bytes_owned.c:9:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*@ from_bytes Owned(p); @*/ + ^~~~~~~~~~ +tests/cn/to_from_bytes_owned.c:11:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Owned(p); @*/ + ^~~~~~~~ +tests/cn/to_from_bytes_owned.c:12:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*@ from_bytes Owned(p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn/tree16/as_auto_mutual_dt/tree16.error.c.verify b/tests/cn/tree16/as_auto_mutual_dt/tree16.error.c.verify new file mode 100644 index 000000000..321f77e62 --- /dev/null +++ b/tests/cn/tree16/as_auto_mutual_dt/tree16.error.c.verify @@ -0,0 +1,5 @@ +return code: 2 +tests/cn/tree16/as_auto_mutual_dt/tree16.error.c:30:21: error: unexpected token after 'list' and before '<' +Please add error message for state 1012 to parsers/c/c_parser_error.messages + Node {i32 v, list children} + ^ diff --git a/tests/cn/tree16/as_mutual_dt/coq_lemmas/Makefile b/tests/cn/tree16/as_mutual_dt/coq_lemmas/Makefile index 64c061784..cff60588a 100644 --- a/tests/cn/tree16/as_mutual_dt/coq_lemmas/Makefile +++ b/tests/cn/tree16/as_mutual_dt/coq_lemmas/Makefile @@ -1,8 +1,4 @@ - - - all: coq_makefile -f _CoqProject -o Makefile.coq - cn verify --lemmata theories/Gen_Spec.v ../tree16.c + cn verify ../tree16.c --lemmata theories/Gen_Spec.v &> /dev/null make -f Makefile.coq - diff --git a/tests/cn/tree16/as_mutual_dt/coq_lemmas/_CoqProject b/tests/cn/tree16/as_mutual_dt/coq_lemmas/_CoqProject index 012738ab4..30ef14952 100644 --- a/tests/cn/tree16/as_mutual_dt/coq_lemmas/_CoqProject +++ b/tests/cn/tree16/as_mutual_dt/coq_lemmas/_CoqProject @@ -1,9 +1,6 @@ - -Q theories CN_Lemmas theories/CN_Lib.v theories/Gen_Spec.v theories/Setup.v theories/Inst_Spec.v - - diff --git a/tests/cn/tree16/as_mutual_dt/tree16.c.verify b/tests/cn/tree16/as_mutual_dt/tree16.c.verify new file mode 100644 index 000000000..dd5e9c2d0 --- /dev/null +++ b/tests/cn/tree16/as_mutual_dt/tree16.c.verify @@ -0,0 +1,15 @@ +return code: 0 +tests/cn/tree16/as_mutual_dt/tree16.c:42:10: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. + take Ns = each (i32 i; (0i32 <= i) && (i < NUM_NODES)) + ^ +tests/cn/tree16/as_mutual_dt/tree16.c:111:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs = each (i32 j; (0i32 <= j) && (j < path_len)) + ^ +tests/cn/tree16/as_mutual_dt/tree16.c:121:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) + ^ +other location (Cn__Compile.UsingLoads.handle.load) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. + +other location (Cn__Compile.UsingLoads.handle.load) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. + +[1/1]: lookup_rec -- pass diff --git a/tests/cn/tree16/as_partial_map/coq_lemmas/Makefile b/tests/cn/tree16/as_partial_map/coq_lemmas/Makefile index f3f0a1b03..cff60588a 100644 --- a/tests/cn/tree16/as_partial_map/coq_lemmas/Makefile +++ b/tests/cn/tree16/as_partial_map/coq_lemmas/Makefile @@ -1,8 +1,4 @@ - - - all: coq_makefile -f _CoqProject -o Makefile.coq - cn verify ../tree16.c --lemmata theories/Gen_Spec.v + cn verify ../tree16.c --lemmata theories/Gen_Spec.v &> /dev/null make -f Makefile.coq - diff --git a/tests/cn/tree16/as_partial_map/coq_lemmas/_CoqProject b/tests/cn/tree16/as_partial_map/coq_lemmas/_CoqProject index 012738ab4..30ef14952 100644 --- a/tests/cn/tree16/as_partial_map/coq_lemmas/_CoqProject +++ b/tests/cn/tree16/as_partial_map/coq_lemmas/_CoqProject @@ -1,9 +1,6 @@ - -Q theories CN_Lemmas theories/CN_Lib.v theories/Gen_Spec.v theories/Setup.v theories/Inst_Spec.v - - diff --git a/tests/cn/tree16/as_partial_map/tree16.c.verify b/tests/cn/tree16/as_partial_map/tree16.c.verify new file mode 100644 index 000000000..a07da7874 --- /dev/null +++ b/tests/cn/tree16/as_partial_map/tree16.c.verify @@ -0,0 +1,22 @@ +return code: 0 +tests/cn/tree16/as_partial_map/tree16.c:22:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function num_nodes; @*/ + ^~~~~~~~~~~ +tests/cn/tree16/as_partial_map/tree16.c:55:10: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. + take Ns = each (i32 i; (0i32 <= i) && (i < (num_nodes ()))) + ^ +tests/cn/tree16/as_partial_map/tree16.c:75:8: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs = each (i32 j; (0i32 <= j) && (j < len)) + ^ +tests/cn/tree16/as_partial_map/tree16.c:137:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs = each (i32 j; (0i32 <= j) && (j < path_len)) + ^ +tests/cn/tree16/as_partial_map/tree16.c:146:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) + ^ +other location (Cn__Compile.UsingLoads.handle.load) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. + +other location (Cn__Compile.UsingLoads.handle.load) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. + +[1/2]: cn_get_num_nodes -- pass +[2/2]: lookup_rec -- pass diff --git a/tests/cn/tree_rev01.c.verify b/tests/cn/tree_rev01.c.verify new file mode 100644 index 000000000..f1d36f13e --- /dev/null +++ b/tests/cn/tree_rev01.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: rev_tree -- pass diff --git a/tests/cn/type_synonym.c.verify b/tests/cn/type_synonym.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/type_synonym.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/unary_negation.c.verify b/tests/cn/unary_negation.c.verify new file mode 100644 index 000000000..75a635a02 --- /dev/null +++ b/tests/cn/unary_negation.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: check_simplify -- pass diff --git a/tests/cn/unary_negation.error.c.verify b/tests/cn/unary_negation.error.c.verify new file mode 100644 index 000000000..802e36890 --- /dev/null +++ b/tests/cn/unary_negation.error.c.verify @@ -0,0 +1,4 @@ +return code: 1 +tests/cn/unary_negation.error.c:3:5: error: Value -129 does not fit i8 + -129i8 + ^~~~~~ diff --git a/tests/cn/unconstrained_ptr_eq.error.c.verify b/tests/cn/unconstrained_ptr_eq.error.c.verify new file mode 100644 index 000000000..b1f2c8c11 --- /dev/null +++ b/tests/cn/unconstrained_ptr_eq.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/unconstrained_ptr_eq.error.c:7:5: error: Unprovable constraint + return p == q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/unconstrained_ptr_eq.error.c:4:5: + return == 0i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__unconstrained_ptr_eq.error.c__f.html diff --git a/tests/cn/unconstrained_ptr_eq2.error.c.verify b/tests/cn/unconstrained_ptr_eq2.error.c.verify new file mode 100644 index 000000000..810e8c0bb --- /dev/null +++ b/tests/cn/unconstrained_ptr_eq2.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/unconstrained_ptr_eq2.error.c:7:5: error: Unprovable constraint + return p == q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/unconstrained_ptr_eq2.error.c:4:5: + return == 1i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__unconstrained_ptr_eq2.error.c__f.html diff --git a/tests/cn/unsupported_flexible_array_member.error.c.verify b/tests/cn/unsupported_flexible_array_member.error.c.verify new file mode 100644 index 000000000..9e9f32485 --- /dev/null +++ b/tests/cn/unsupported_flexible_array_member.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/unsupported_flexible_array_member.error.c:3:9: error: unsupported flexible array members + int y[]; + ^ diff --git a/tests/cn/unsupported_union.error.c.verify b/tests/cn/unsupported_union.error.c.verify new file mode 100644 index 000000000..06c6db186 --- /dev/null +++ b/tests/cn/unsupported_union.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/unsupported_union.error.c:1:1: error: unsupported union types +union union_test { +~~~~~~^~~~~~~~~~~~ diff --git a/tests/cn/use_enum.c.verify b/tests/cn/use_enum.c.verify new file mode 100644 index 000000000..bdde7b0a5 --- /dev/null +++ b/tests/cn/use_enum.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: add_x_y -- pass diff --git a/tests/cn/use_typedef.c.verify b/tests/cn/use_typedef.c.verify new file mode 100644 index 000000000..f17d536af --- /dev/null +++ b/tests/cn/use_typedef.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: test -- pass diff --git a/tests/cn/verify.json b/tests/cn/verify.json new file mode 100644 index 000000000..dfab4251f --- /dev/null +++ b/tests/cn/verify.json @@ -0,0 +1,6 @@ +{ + "name": "verify", + "args": ["verify"], + "filter": "^(.*\\.c)$", + "timeout": 60 +} diff --git a/tests/cn/void_star_arg.c.verify b/tests/cn/void_star_arg.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/void_star_arg.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn_vip_testsuite/README.md b/tests/cn_vip_testsuite/README.md new file mode 100644 index 000000000..48b9fe48a --- /dev/null +++ b/tests/cn_vip_testsuite/README.md @@ -0,0 +1,13 @@ +# PNVI-ae-udi/VIP testsuite adapted for CN +--- +* VIP does not have non-det. pointer equality but CN does +* The addition of ghost parameters to CN may increase the expressiveness of the memory model + +## To do +* Add support round trip casts +* Add support preserving pointer provenance via bytes +* Add support memcpy_proxy +* Add support unions +* Fix peformance bug for pointer\_copy\_user\_ctrflow\_bytewise.c +* `tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c:1:// NOTE: terminates with cvc5 but not Z3` +* `tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c:1:// NOTE: terminates with cvc5 but not Z3` diff --git a/tests/cn_vip_testsuite/cheri_03_ii.error.c.no_annot b/tests/cn_vip_testsuite/cheri_03_ii.error.c.no_annot new file mode 100644 index 000000000..4246f6e43 --- /dev/null +++ b/tests/cn_vip_testsuite/cheri_03_ii.error.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/cheri_03_ii.error.c:6:12: error: `&&x[(u64)11'i32]` out of bounds + int *q = p + 11; // CN VIP UB + ~~^~~~ +(UB missing short message): UB_CERB004_unspecified__pointer_add +State file: file:///tmp/state__cheri_03_ii.error.c__main.html diff --git a/tests/cn_vip_testsuite/no_annot.json b/tests/cn_vip_testsuite/no_annot.json new file mode 100644 index 000000000..0d3a8bdb1 --- /dev/null +++ b/tests/cn_vip_testsuite/no_annot.json @@ -0,0 +1,6 @@ +{ + "name": "no_annot", + "args": ["verify", "-DVIP", "-DNO_ROUND_TRIP", "--solver-type=cvc5" ], + "filter": "^(.*\\.c)$", + "timeout": 35 +} diff --git a/tests/cn_vip_testsuite/non_det_false.json b/tests/cn_vip_testsuite/non_det_false.json new file mode 100644 index 000000000..6d3745e7c --- /dev/null +++ b/tests/cn_vip_testsuite/non_det_false.json @@ -0,0 +1,6 @@ +{ + "name": "non_det_false", + "args": ["verify", "-DVIP", "-DNO_ROUND_TRIP", "-DNON_DET_FALSE", "--solver-type=cvc5" ], + "filter": "^(.*\\.nondet.c)$", + "timeout": 35 +} diff --git a/tests/cn_vip_testsuite/non_det_true.json b/tests/cn_vip_testsuite/non_det_true.json new file mode 100644 index 000000000..acc45731c --- /dev/null +++ b/tests/cn_vip_testsuite/non_det_true.json @@ -0,0 +1,6 @@ +{ + "name": "non_det_true", + "args": ["verify", "-DVIP", "-DNO_ROUND_TRIP", "-DNON_DET_TRUE", "--solver-type=cvc5" ], + "filter": "^(.*\\.nondet\\.c)$", + "timeout": 35 +} diff --git a/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.no_annot new file mode 100644 index 000000000..c582e6865 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c:20:3: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_arith_algebraic_properties_2_global.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.no_annot new file mode 100644 index 000000000..22bd37b66 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c:21:3: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_arith_algebraic_properties_3_global.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_copy_memcpy.c b/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_copy_memcpy.c rename to tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c diff --git a/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot new file mode 100644 index 000000000..8ca1980fa --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:11:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Block(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:14:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.no_annot new file mode 100644 index 000000000..0dcac67f6 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c:41:3: error: Missing resource for writing + *q = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_copy_user_ctrlflow_bitwise.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.unprovable.c b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.unprovable.c rename to tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c diff --git a/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c.no_annot new file mode 100644 index 000000000..2c7128919 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c.no_annot @@ -0,0 +1 @@ +TIMEOUT diff --git a/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.c b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.c rename to tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c diff --git a/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot new file mode 100644 index 000000000..2c7128919 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot @@ -0,0 +1 @@ +TIMEOUT diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c new file mode 100644 index 000000000..63abe838e --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c @@ -0,0 +1,34 @@ +#include "refinedc.h" + +//CN_VIP #include +#include +#include +#include +#include "cn_lemmas.h" +int y=2, x=1; +int main() +/*CN_VIP*//*@ accesses y; accesses x; requires x == 1i32; @*/ +{ + int *p = &x+1; + int *q = &y; + uintptr_t i = (uintptr_t)p; + uintptr_t j = (uintptr_t)q; + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + /*CN_VIP*/int result = _memcmp((unsigned char*)&p, (unsigned char*)&q, sizeof(p)); + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ +#ifdef NO_ROUND_TRIP + q = copy_alloc_id(j, &y); +#endif + if (result == 0) { +#ifdef ANNOT + int *r = copy_alloc_id(i, q); +#else + int *r = (int *)i; +#endif + *r=11; // is this free of UB? + /*CN_VIP*//*@ assert (x == 1i32 && y == 11i32 && *q == 11i32 && *r == 11i32); @*/ + //CN_VIP printf("x=%d y=%d *q=%d *r=%d\n",x,y,*q,*r); + } +} diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot new file mode 100644 index 000000000..337c08e78 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:30:5: error: Missing resource for writing + *r=11; // is this free of UB? + ~~^~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_int_disambiguation_1.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot new file mode 100644 index 000000000..210e61dec --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.unprovable.c b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.unprovable.c deleted file mode 100644 index 26476aa21..000000000 --- a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.unprovable.c +++ /dev/null @@ -1,22 +0,0 @@ -#include "refinedc.h" - -//CN_VIP #include -#include -#include -#include -int y=2, x=1; -int main() { - int *p = &x+1; - int *q = &y; - uintptr_t i = (uintptr_t)p; - uintptr_t j = (uintptr_t)q; - if (memcmp(&p, &q, sizeof(p)) == 0) { -#if defined(ANNOT) - int *r = copy_alloc_id(i, q); -#else - int *r = (int *)i; -#endif - *r=11; // is this free of UB? - //CN_VIP printf("x=%d y=%d *q=%d *r=%d\n",x,y,*q,*r); - } -} diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.c b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.c rename to tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot new file mode 100644 index 000000000..4bfc43d8c --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot new file mode 100644 index 000000000..e4d756067 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot @@ -0,0 +1,20 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:34:5: error: Missing resource for writing + *r=11; // CN VIP UB if ¬ANNOT + ~~^~~ +Resource needed: Block(copy_alloc_id((u64)intToPtr + , copy_alloc_id((u64)value, &x))) +State file: file:///tmp/state__pointer_from_int_disambiguation_3.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot new file mode 100644 index 000000000..d71c5d52d --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:35:7: error: `©_alloc_id((u64)&&x[1'u64], copy_alloc_id((u64)value, &y))[(u64)(0'i32 - 1'i32)]` out of bounds + r=r-1; // CN VIP UB if NO_ROUND TRIP && ANNOT + ~^~ +(UB missing short message): UB_CERB004_unspecified__pointer_add +State file: file:///tmp/state__pointer_from_int_disambiguation_3.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1i.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c similarity index 84% rename from tests/cn_vip_testsuite/pointer_from_integer_1i.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c index 1c2cf750d..625f1cbab 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1i.unprovable.c +++ b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c @@ -3,8 +3,10 @@ //CN_VIP #include #include #include "charon_address_guesses.h" +#include "cn_lemmas.h" void f(uintptr_t i) { int j=5; + /*@ apply assert_equal(i, (u64)&j); @*/ #if defined(ANNOT) int *p = copy_alloc_id(i, &j); #else diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.no_annot new file mode 100644 index 000000000..f0d2bf11d --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c:15:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_1i.annot.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.with_annot new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.with_annot @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ie.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c similarity index 86% rename from tests/cn_vip_testsuite/pointer_from_integer_1ie.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c index cd44285c3..61ddda767 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1ie.unprovable.c +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c @@ -3,9 +3,11 @@ //CN_VIP #include #include #include "charon_address_guesses.h" +#include "cn_lemmas.h" void f(uintptr_t i) { int j=5; uintptr_t k = (uintptr_t)&j; + /*@ apply assert_equal(i, k); @*/ #if defined(ANNOT) int *p = copy_alloc_id(i, &j); #else diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.no_annot new file mode 100644 index 000000000..fd92ee9ff --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c:16:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_1ie.annot.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.with_annot new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.with_annot @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot new file mode 100644 index 000000000..4519854db --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c:16:5: error: Missing resource for writing + *p=7; // CN VIP UB (no annot) + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_1ig.annot.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.with_annot new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.with_annot @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c.no_annot new file mode 100644 index 000000000..c552fb4bf --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c:6:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(p) +State file: file:///tmp/state__pointer_from_integer_1p.unprovable.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot new file mode 100644 index 000000000..cbcac5e51 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c:7:5: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(p) +State file: file:///tmp/state__pointer_from_integer_1pg.unprovable.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c.no_annot new file mode 100644 index 000000000..d4af4fbc2 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c:7:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_2.unprovable.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c.no_annot new file mode 100644 index 000000000..f9d410b46 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c:7:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_2g.unprovable.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot new file mode 100644 index 000000000..b61714190 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:22:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:25:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:33:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__pointer_offset_from_int_subtraction_auto_xy.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot new file mode 100644 index 000000000..0069b3ddb --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:22:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:25:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot new file mode 100644 index 000000000..cc475aa53 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:22:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:25:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:33:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__pointer_offset_from_int_subtraction_auto_yx.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot new file mode 100644 index 000000000..dae5361dd --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:22:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:25:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot new file mode 100644 index 000000000..b42a4d87e --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:35:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__pointer_offset_from_int_subtraction_global_xy.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot new file mode 100644 index 000000000..2422839bd --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot new file mode 100644 index 000000000..e4b98e8fb --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:35:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__pointer_offset_from_int_subtraction_global_yx.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot new file mode 100644 index 000000000..f3cafd1e4 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot new file mode 100644 index 000000000..70bdfc0ec --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&r); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:13:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&r); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:16:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:10:22: error: Undefined behaviour + ptrdiff_t offset = q - p; // CN VIP UB + ~~^~~ +the subtraction of two pointers must be between pointers that points into, or just beyond, the same array object (§6.5.6#9, sentence 1) +State file: file:///tmp/state__pointer_offset_from_ptr_subtraction_auto_xy.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot new file mode 100644 index 000000000..97031e53f --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&r); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:13:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&r); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:16:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:10:22: error: Undefined behaviour + ptrdiff_t offset = q - p; // CN VIP UB + ~~^~~ +the subtraction of two pointers must be between pointers that points into, or just beyond, the same array object (§6.5.6#9, sentence 1) +State file: file:///tmp/state__pointer_offset_from_ptr_subtraction_auto_yx.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot new file mode 100644 index 000000000..bf6314401 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:14:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&r); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:15:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:17:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&r); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:18:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:12:22: error: Undefined behaviour + ptrdiff_t offset = q - p; // CN VIP UB + ~~^~~ +the subtraction of two pointers must be between pointers that points into, or just beyond, the same array object (§6.5.6#9, sentence 1) +State file: file:///tmp/state__pointer_offset_from_ptr_subtraction_global_xy.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot new file mode 100644 index 000000000..247144502 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:14:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&r); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:15:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:17:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&r); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:18:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:12:22: error: Undefined behaviour + ptrdiff_t offset = q - p; // CN VIP UB + ~~^~~ +the subtraction of two pointers must be between pointers that points into, or just beyond, the same array object (§6.5.6#9, sentence 1) +State file: file:///tmp/state__pointer_offset_from_ptr_subtraction_global_yx.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.no_annot new file mode 100644 index 000000000..925eb6baa --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c:19:3: error: Missing resource for writing + *r = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_offset_xor_auto.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.no_annot new file mode 100644 index 000000000..0d74be545 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c:22:3: error: Missing resource for writing + *r = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_offset_xor_global.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot new file mode 100644 index 000000000..e8a3c93c2 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:10:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:11:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:13:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:14:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:19:5: error: Missing resource for writing + *p = 11; // CN VIP UB + ~~~^~~~ +Resource needed: Block(copy_alloc_id((u64)value, &x)) +State file: file:///tmp/state__provenance_basic_auto_yx.error.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot new file mode 100644 index 000000000..52770dbba --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:13:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:16:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:21:5: error: Missing resource for writing + *p = 11; // CN_VIP UB + ~~~^~~~ +Resource needed: Block(copy_alloc_id((u64)value, &x)) +State file: file:///tmp/state__provenance_basic_global_yx.error.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot new file mode 100644 index 000000000..178474641 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:26:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:29:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:37:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__provenance_basic_using_uintptr_t_auto_yx.annot.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot new file mode 100644 index 000000000..88342e382 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:26:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:29:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot new file mode 100644 index 000000000..06e768c20 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:26:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:29:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:37:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__provenance_basic_using_uintptr_t_global_yx.annot.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot new file mode 100644 index 000000000..1eb84e572 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:26:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:29:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.c b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_equality_auto_yx.c rename to tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false new file mode 100644 index 000000000..3dbcf5e08 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:13:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:13:17: + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_auto_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true new file mode 100644 index 000000000..b82c8b7d3 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:11:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:11:17: + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_auto_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_auto_yx.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.c b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.c rename to tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false new file mode 100644 index 000000000..1099a5c7e --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false @@ -0,0 +1,10 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:11:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:11:17: + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_global_fn_yx.nondet.c__f.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true new file mode 100644 index 000000000..47b9a9b7c --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true @@ -0,0 +1,10 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:9:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:9:17: + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_global_fn_yx.nondet.c__f.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.pass.c.no_annot new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.pass.c.no_annot @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.c b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_equality_global_yx.c rename to tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false new file mode 100644 index 000000000..f407d5321 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:14:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:14:17: + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_global_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true new file mode 100644 index 000000000..d93691619 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:12:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:12:17: + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_global_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_yx.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.c b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.c rename to tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.c b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.c rename to tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot new file mode 100644 index 000000000..fe54164b4 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot @@ -0,0 +1,19 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&i1); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&i4); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&i1); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&i4); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:30:5: error: Missing resource for writing + *q = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__provenance_lost_escape_1.annot.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot new file mode 100644 index 000000000..d59619ffb --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot @@ -0,0 +1,14 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&i1); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&i4); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&i1); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&i4); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.c b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.c rename to tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c diff --git a/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.c b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.c rename to tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c diff --git a/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.c b/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.c rename to tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c diff --git a/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c.no_annot new file mode 100644 index 000000000..81ab6b5c7 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c.no_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c:32:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.no_annot new file mode 100644 index 000000000..f7ad2aa88 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c:34:3: error: Missing resource for writing + *r = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__provenance_tag_bits_via_uintptr_t_1.annot.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_union_punning_2_auto_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_union_punning_2_auto_yx.error.c.no_annot new file mode 100644 index 000000000..d40bd5b50 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_union_punning_2_auto_yx.error.c.no_annot @@ -0,0 +1,4 @@ +return code: 2 +tests/cn_vip_testsuite/provenance_union_punning_2_auto_yx.error.c:4:9: error: unsupported union types +typedef union { uintptr_t ui; int *p; } un; + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn_vip_testsuite/provenance_union_punning_2_global_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_union_punning_2_global_yx.error.c.no_annot new file mode 100644 index 000000000..231e6daa4 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_union_punning_2_global_yx.error.c.no_annot @@ -0,0 +1,4 @@ +return code: 2 +tests/cn_vip_testsuite/provenance_union_punning_2_global_yx.error.c:5:9: error: unsupported union types +typedef union { uintptr_t ui; int *p; } un; + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn_vip_testsuite/provenance_union_punning_3_global.c b/tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_union_punning_3_global.c rename to tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c diff --git a/tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c.no_annot new file mode 100644 index 000000000..b9ed6d88c --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c.no_annot @@ -0,0 +1,4 @@ +return code: 2 +tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c:5:9: error: unsupported union types +typedef union { uintptr_t ui; int *up; } un; + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn_vip_testsuite/with_annot.json b/tests/cn_vip_testsuite/with_annot.json new file mode 100644 index 000000000..24e73d01c --- /dev/null +++ b/tests/cn_vip_testsuite/with_annot.json @@ -0,0 +1,6 @@ +{ + "name": "with_annot", + "args": ["verify", "-DVIP", "-DANNOT", "-DNO_ROUND_TRIP", "--solver-type=cvc5" ], + "filter": "^((pointer_from_int_disambiguation_3\\.error\\.c)|(.*\\.annot\\.c))$", + "timeout": 35 +} diff --git a/tests/diff-prog.py b/tests/diff-prog.py new file mode 100755 index 000000000..d102521d9 --- /dev/null +++ b/tests/diff-prog.py @@ -0,0 +1,110 @@ +#!/usr/bin/env python3 + +import os, sys, re, subprocess, json, difflib, argparse, concurrent.futures + +def eprint(*args, then_exit=True, **kwargs): + print('Error:', *args, file=sys.stderr, **kwargs) + if then_exit: + exit(1) + +class Prog: + + def __init__(self, args, config): + self.prog = args.prog + self.args = config['args'] + self.print_cmd = args.dry_run or args.verbose + self.run_cmd = not args.dry_run + self.timeout = config['timeout'] + self.name = config['name'] + self.matcher = re.compile(config['filter']) + self.suffix = args.suffix + + def run(self, test_rel_path): + cmd = [self.prog] + self.args + [test_rel_path] + if self.print_cmd: + print(' '.join(cmd)) + if self.run_cmd: + return subprocess.run(cmd, stdout=subprocess.PIPE, stderr=subprocess.STDOUT, text=True, timeout=self.timeout) + else: + return None + + def output(self, test_rel_path): + try: + completed = self.run(test_rel_path); + result = ("return code: %d\n%s" % (completed.returncode, completed.stdout)) + except subprocess.TimeoutExpired: + result = "TIMEOUT\n" + return result.splitlines(True) + + def get_diff(self, test_rel_path): + expect_path = test_rel_path + '.' + self.name + if not os.path.isfile(expect_path): + open(expect_path, 'w') + with open(expect_path, 'r') as expect: + try: + return list(difflib.unified_diff(expect.readlines(), self.output(test_rel_path), expect_path, expect_path)) + except AttributeError: # dry run + return False + +def test_files(test_dir, matcher): + if not os.path.isdir(test_dir): + eprint(f"'{test_dir}' not a directory") + for root, _, files in os.walk(test_dir): + for filename in files: + if matcher.match(filename) is not None: + yield os.path.join(root, filename) + + +def filter_tests(**kwargs): + test_dir = kwargs['test_dir'] + suffix = kwargs['suffix'] + matcher = kwargs['matcher'] + inputs = test_files(test_dir, matcher) + if suffix is not None: + inputs = list(filter(lambda x : x.endswith(suffix), inputs)) + inputs_len = len(inputs) + if inputs_len > 1: + eprint(f'more than one file matching *{suffix} found in {test_dir}', then_exit=False) + eprint(inputs) + elif inputs_len == 0: + eprint(f'*{suffix} not found in {test_dir}') + return inputs + +def run_tests(prog, **kwargs): + quiet = kwargs['quiet'] + test_rel_paths = list(filter_tests(**kwargs)) + with concurrent.futures.ProcessPoolExecutor() as executor: + failed_tests = 0 + for test_rel_path, diff in zip(test_rel_paths, executor.map(prog.get_diff, test_rel_paths)): + if not prog.run_cmd: + continue + pass_fail = '\033[32m[ PASSED ]\033[m' + if diff: + failed_tests += 1 + sys.stderr.writelines(diff) + pass_fail = '\033[31m[ FAILED ]\033[m' + if not quiet: + print('%s %s' % (pass_fail, test_rel_path)) + return min(failed_tests, 1) + +def main(args): + with open(args.config) as config_file: + config = json.load(config_file) + prog = Prog(args, config) + return run_tests(prog, test_dir=os.path.dirname(args.config), suffix=args.suffix, matcher=re.compile(config['filter']), quiet=args.quiet) + +# top level +parser = argparse.ArgumentParser(description="Script for running an executable and diffing the output.") +parser.set_defaults(func=(lambda _: parser.parse_args(['-h']))) +parser.add_argument('prog') +parser.add_argument('config', help='Path to JSON config file: { "name": string; "args": string list; "filter": python regexp; "timeout": seconds }.') +parser.add_argument('-v', '--verbose', help='Print commands used.', action='store_true') +parser.add_argument('--dry-run', help='Print but do not run commands.', action='store_true') +parser.add_argument('--suffix', help='Uniquely identifying suffix of a file in the test directory.') +parser.add_argument('--quiet', help='Don\'t show tests completed so far on std out.', action='store_true') +parser.set_defaults(func=main) + +# parse args and call func (as set using set_defaults) +args = parser.parse_args() +args.func(args) + diff --git a/tests/run-cn-lemmas.sh b/tests/run-cn-lemmas.sh new file mode 100755 index 000000000..7fe3a4ab1 --- /dev/null +++ b/tests/run-cn-lemmas.sh @@ -0,0 +1,42 @@ +#!/usr/bin/env bash +set -euo pipefail -o noclobber + +function exits_with_code() { + local action=$1 + local file=$2 + local -a expected_exit_codes=$3 + + printf "[$file]...\n" + timeout 60 ${action} "$file" + local result=$? + + for code in "${expected_exit_codes[@]}"; do + if [ $result -eq $code ]; then + printf "\033[32mPASS\033[0m\n" + return 0 + fi + done + + printf "\033[31mFAIL\033[0m (Unexpected return code: %d)\n" "$result" + return 1 +} + +DIRNAME=$(dirname "$0") + +FAILED="" + +COQ_LEMMAS=$(find "${DIRNAME}"/cn -type d -name 'coq_lemmas') + +for TEST in ${COQ_LEMMAS}; do + if ! exits_with_code "make -C" "${TEST}" 0; then + FAILED+=" ${TEST}" + fi +done + +if [ -z "${FAILED}" ]; then + exit 0 +else + printf "\033[31mFAILED: %s\033[0m\n" "${FAILED}" + exit 1 +fi + diff --git a/tests/run-cn-tutorial-ci.sh b/tests/run-cn-tutorial-ci.sh index 753086dd7..da33d5add 100755 --- a/tests/run-cn-tutorial-ci.sh +++ b/tests/run-cn-tutorial-ci.sh @@ -10,9 +10,6 @@ else exit 1 fi -# copying from run-ci.sh -export DYLD_LIBRARY_PATH=$DYLD_LIBRARY_PATH:`ocamlfind query z3` -export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:`ocamlfind query z3` CN=$OPAM_SWITCH_PREFIX/bin/cn HERE=$(pwd) diff --git a/tests/run-cn-vip.sh b/tests/run-cn-vip.sh index 9a2404c22..57db20ac4 100755 --- a/tests/run-cn-vip.sh +++ b/tests/run-cn-vip.sh @@ -1,98 +1,7 @@ #!/usr/bin/env bash set -euo pipefail -o noclobber -USAGE="USAGE: $0 [-h]" - -function echo_and_err() { - printf "%s\n" "$1" - exit 1 -} - -LEMMATA=0 - -while getopts "h" flag; do - case "$flag" in - h) - printf "%s\n" "${USAGE}" - exit 0 - ;; - \?) - echo_and_err "${USAGE}" - ;; - esac -done - -function exits_with_code() { - local action=$1 - local file=$2 - local -a expected_exit_codes=$3 - - printf "[$file]...\n" - timeout 35 ${action} "$file" &> /dev/null - local result=$? - - for code in "${expected_exit_codes[@]}"; do - if [ $result -eq $code ]; then - printf "\033[32mPASS\033[0m\n" - return 0 - fi - done - - printf "\033[31mFAIL\033[0m (Unexpected return code: %d)\n" "$result" - return 1 -} - -DIRNAME=$(dirname "$0") - -SUCC=$( - find $DIRNAME/cn_vip_testsuite -name '*.c' \ - \! -name '*union*.c' \ - \! -name '*.unprovable.c' \ - \! -name '*.annot.c' \ - \! -name '*.error.c' \ -) -UNION=$(find $DIRNAME/cn_vip_testsuite -name '*union*.c') -UNPROV=$(find $DIRNAME/cn_vip_testsuite -name '*.unprovable.c' \ - \! -name 'pointer_copy_user_ctrlflow_bytewise.unprovable.c') - # this test hits a CN performance bug -FAIL=$(find $DIRNAME/cn_vip_testsuite -name '*.error.c' \! -name '*union*.c') -ANNOT=$(find $DIRNAME/cn_vip_testsuite -name '*.annot.c') - -FAILED='' - -for TEST in ${SUCC} ${ANNOT}; do - if ! exits_with_code "cn verify -DVIP -DANNOT -DNO_ROUND_TRIP --solver-type=cvc5" "${TEST}" 0; then - FAILED+=" ${TEST}" - fi -done - -for TEST in $FAIL $ANNOT $UNPROV; do - if ! exits_with_code "cn verify -DVIP -DNO_ROUND_TRIP --solver-type=cvc5" "${TEST}" 1; then - FAILED+=" ${TEST}" - fi -done - - -NON_DET=( - $DIRNAME/provenance_equality_auto_yx.c \ - $DIRNAME/provenance_equality_global_fn_yx.c \ - $DIRNAME/provenance_equality_global_yx.c \ -) - -for TEST in $NON_DET; do - if ! exits_with_code "cn verify -DVIP -DNO_ROUND_TRIP -DNON_DET_TRUE --solver-type=cvc5" "${TEST}" 1; then - FAILED+=" ${TEST} (nd. true)" - fi - if ! exits_with_code "cn verify -DVIP -DNO_ROUND_TRIP -DNON_DET_FALSE --solver-type=cvc5" "${TEST}" 1; then - FAILED+=" ${TEST} (nd. false)" - fi -done - -if [ -z "${FAILED}" ]; then - exit 0 -else - printf "\033[31mFAILED: %s\033[0m\n" "${FAILED}" - exit 1 -fi - - +for file in "$(dirname $0)"/cn_vip_testsuite/*.json +do + ./tests/diff-prog.py cn "$file" 2> "${file%.json}.patch" || (cat "${file%.json}.patch"; exit 1) +done || exit 1 diff --git a/tests/run-cn.sh b/tests/run-cn.sh index 610597c01..509125c42 100755 --- a/tests/run-cn.sh +++ b/tests/run-cn.sh @@ -13,6 +13,8 @@ function echo_and_err() { exit 1 } +printf "\033[31mDEPRECATED\033[0m please use diff-prog.py (see ci-cn.yml)\n" "$result" + LEMMATA=0 while getopts "hl" flag; do From 384bddca5311be6bf6d131a69f71ce8c23a3e9bb Mon Sep 17 00:00:00 2001 From: Peter Sewell Date: Sat, 23 Nov 2024 07:18:06 +0000 Subject: [PATCH 068/148] Update README.md (#724) --- backend/cn/README.md | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/backend/cn/README.md b/backend/cn/README.md index b89883ffe..843762da4 100644 --- a/backend/cn/README.md +++ b/backend/cn/README.md @@ -1,8 +1,12 @@ # CN CN is tool for verifying C code is free of undefined behaviour and meets -user-written specifications. It can also convert those specifications into -C assertions to be checked at runtime on concrete test cases. +user-written specifications of its ownership and functional correctness, and for translating those specifications into +C assertions that can be checked at runtime on concrete test cases. + +## Tutorial + +See the [tutorial documentation](https://rems-project.github.io/cn-tutorial/). ## Installation @@ -56,6 +60,3 @@ for logistics and our [onboarding guide](https://github.com/rems-project/cerberus/blob/master/backend/cn/ONBOARDING.md) for learning the code base. -## Funding Acknowledgements - -TODO (PS?) From 263ec7f46282a3e39e8f7f502235983771334876 Mon Sep 17 00:00:00 2001 From: Peter Sewell Date: Sat, 23 Nov 2024 07:47:43 +0000 Subject: [PATCH 069/148] Update README.md - add links to papers (#725) --- backend/cn/README.md | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/backend/cn/README.md b/backend/cn/README.md index 843762da4..8a0d1c2a5 100644 --- a/backend/cn/README.md +++ b/backend/cn/README.md @@ -1,9 +1,38 @@ # CN -CN is tool for verifying C code is free of undefined behaviour and meets +CN is a tool for verifying that C code is free of undefined behaviour and meets user-written specifications of its ownership and functional correctness, and for translating those specifications into C assertions that can be checked at runtime on concrete test cases. +## Papers + + + + ## Tutorial See the [tutorial documentation](https://rems-project.github.io/cn-tutorial/). From ede24dc5b3409e7554279a6a919975e838530d2f Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sat, 23 Nov 2024 20:57:45 +0000 Subject: [PATCH 070/148] Fix run-cn.sh (#726) --- tests/run-cn.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/run-cn.sh b/tests/run-cn.sh index 509125c42..848d445b3 100755 --- a/tests/run-cn.sh +++ b/tests/run-cn.sh @@ -13,7 +13,7 @@ function echo_and_err() { exit 1 } -printf "\033[31mDEPRECATED\033[0m please use diff-prog.py (see ci-cn.yml)\n" "$result" +printf "\033[31mDEPRECATED\033[0m please use diff-prog.py (see ci-cn.yml)\n" LEMMATA=0 From 6059dddd55e3fac8f048ab67be752a92d181ce3b Mon Sep 17 00:00:00 2001 From: Vadim Zaliva Date: Wed, 4 Dec 2024 12:07:12 -0800 Subject: [PATCH 071/148] CHERI CI dependency fix (#737) Pinned coq-cheri-capabilities dependency to last known good version. Fixes #736 --- .github/workflows/ci.yml | 2 +- Dockerfile.cheri | 2 +- README-cheri.md | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 93d535f5b..7a6086bfb 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -50,7 +50,7 @@ jobs: opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git + opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git#2f02c44ad061d4da30136dc9dbc06c142c94fdaf opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - name: Save cached opam diff --git a/Dockerfile.cheri b/Dockerfile.cheri index edf8e8249..56363687b 100644 --- a/Dockerfile.cheri +++ b/Dockerfile.cheri @@ -12,7 +12,7 @@ RUN opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/rel && opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git \ && opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git \ && opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad \ - && opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git \ + && opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git#2f02c44ad061d4da30136dc9dbc06c142c94fdaf \ && opam pin add -n --yes cerberus-lib https://github.com/rems-project/cerberus.git \ && opam pin add -n --yes cerberus https://github.com/rems-project/cerberus.git \ && opam pin add -n --yes cerberus-cheri https://github.com/rems-project/cerberus.git diff --git a/README-cheri.md b/README-cheri.md index 087971959..c427e769c 100644 --- a/README-cheri.md +++ b/README-cheri.md @@ -31,7 +31,7 @@ opam repo add --this-switch coq-released https://coq.inria.fr/opam/released opam pin -ny coq-struct-tact https://github.com/uwplse/StructTact.git opam repo add --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git opam pin -ny coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad -opam pin -ny coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git +opam pin -ny coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git#2f02c44ad061d4da30136dc9dbc06c142c94fdaf ``` Install the remaining dependencies using opam: From d4363cf162106a9f882d7000e88920376107bfb1 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 2 Dec 2024 12:57:06 -0500 Subject: [PATCH 072/148] [CN-Test-Gen] Expose `sized-null` via `cn test` --- backend/cn/bin/main.ml | 65 +++++++++++-------- backend/cn/lib/testGeneration/specTests.ml | 7 +- .../cn/lib/testGeneration/testGenConfig.ml | 4 ++ .../cn/lib/testGeneration/testGenConfig.mli | 3 + 4 files changed, 51 insertions(+), 28 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index d540110a2..74b529ae4 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -448,6 +448,7 @@ let run_tests exit_fast max_stack_depth max_generator_size + sized_null coverage disable_passes = @@ -515,6 +516,7 @@ let run_tests exit_fast; max_stack_depth; max_generator_size; + sized_null; coverage; disable_passes } @@ -882,16 +884,16 @@ module Testing_flags = struct let only = - let doc = "only test this function (or comma-separated names)" in + let doc = "Only test this function (or comma-separated names)" in Arg.(value & opt (some string) None & info [ "only" ] ~doc) let skip = - let doc = "skip testing of this function (or comma-separated names)" in + let doc = "Skip testing of this function (or comma-separated names)" in Arg.(value & opt (some string) None & info [ "skip" ] ~doc) - let dont_run_tests = + let dont_run = let doc = "Do not run tests, only generate them" in Arg.(value & flag & info [ "no-run" ] ~doc) @@ -921,7 +923,7 @@ module Testing_flags = struct & info [ "max-unfolds" ] ~doc) - let test_max_array_length = + let max_array_length = let doc = "Set the maximum length for an array generated" in Arg.( value @@ -929,7 +931,7 @@ module Testing_flags = struct & info [ "max-array-length" ] ~doc) - let test_null_in_every = + let null_in_every = let doc = "Set the likelihood of NULL being generated as 1 in every " in Arg.( value @@ -937,12 +939,12 @@ module Testing_flags = struct & info [ "null-in-every" ] ~doc) - let test_seed = + let seed = let doc = "Set the seed for random testing" in Arg.(value & opt (some string) TestGeneration.default_cfg.seed & info [ "seed" ] ~doc) - let test_logging_level = + let logging_level = let doc = "Set the logging level for failing inputs from tests" in Arg.( value @@ -950,14 +952,14 @@ module Testing_flags = struct & info [ "logging-level" ] ~doc) - let interactive_testing = + let interactive = let doc = "Enable interactive features for testing, such as requesting more detailed logs" in Arg.(value & flag & info [ "interactive" ] ~doc) - let test_until_timeout = + let until_timeout = let doc = "Keep rerunning tests until the given timeout (in seconds) has been reached" in @@ -967,12 +969,12 @@ module Testing_flags = struct & info [ "until-timeout" ] ~doc) - let test_exit_fast = + let exit_fast = let doc = "Stop testing upon finding the first failure" in Arg.(value & flag & info [ "exit-fast" ] ~doc) - let test_max_stack_depth = + let max_stack_depth = let doc = "Maximum stack depth for generators" in Arg.( value @@ -980,7 +982,7 @@ module Testing_flags = struct & info [ "max-stack-depth" ] ~doc) - let test_max_generator_size = + let max_generator_size = let doc = "Maximum size for generated values" in Arg.( value @@ -988,8 +990,15 @@ module Testing_flags = struct & info [ "max-generator-size" ] ~doc) - let test_coverage = - let doc = "Record coverage of tests" in + let sized_null = + let doc = + "Scale the likelihood of [NULL] proportionally for a desired size (1/n for size n)" + in + Arg.(value & flag & info [ "sized-null" ] ~doc) + + + let coverage = + let doc = "(Experimental) Record coverage of tests via [lcov]" in Arg.(value & flag & info [ "coverage" ] ~doc) @@ -1029,27 +1038,29 @@ let testing_cmd = $ Testing_flags.output_test_dir $ Testing_flags.only $ Testing_flags.skip - $ Testing_flags.dont_run_tests + $ Testing_flags.dont_run $ Testing_flags.gen_num_samples $ Testing_flags.gen_backtrack_attempts $ Testing_flags.gen_max_unfolds - $ Testing_flags.test_max_array_length - $ Testing_flags.test_null_in_every - $ Testing_flags.test_seed - $ Testing_flags.test_logging_level - $ Testing_flags.interactive_testing - $ Testing_flags.test_until_timeout - $ Testing_flags.test_exit_fast - $ Testing_flags.test_max_stack_depth - $ Testing_flags.test_max_generator_size - $ Testing_flags.test_coverage + $ Testing_flags.max_array_length + $ Testing_flags.null_in_every + $ Testing_flags.seed + $ Testing_flags.logging_level + $ Testing_flags.interactive + $ Testing_flags.until_timeout + $ Testing_flags.exit_fast + $ Testing_flags.max_stack_depth + $ Testing_flags.max_generator_size + $ Testing_flags.sized_null + $ Testing_flags.coverage $ Testing_flags.disable_passes in let doc = - "Generates RapidCheck tests for all functions in [FILE] with CN specifications.\n\ + "Generates tests for all functions in [FILE] with CN specifications.\n\ \ The tests use randomized inputs, which are guaranteed to satisfy the CN \ precondition.\n\ - \ A [.cpp] file containing the test harnesses will be placed in [output-dir]." + \ A script [run_tests.sh] for building and running the tests will be placed in \ + [output-dir]." in let info = Cmd.info "test" ~doc in Cmd.v info test_t diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 2c65d30ea..1057ff1b0 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -466,7 +466,12 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = |> Option.map (fun max_generator_size -> [ "--max-generator-size"; string_of_int max_generator_size ]) |> Option.to_list - |> List.flatten)) + |> List.flatten) + @ + if Config.is_sized_null () then + [ "--sized-null" ] + else + []) in cmd ^^ semi diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index 642d20273..1c086ac9d 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -13,6 +13,7 @@ type t = exit_fast : bool; max_stack_depth : int option; max_generator_size : int option; + sized_null : bool; coverage : bool; disable_passes : string list } @@ -30,6 +31,7 @@ let default = exit_fast = false; max_stack_depth = None; max_generator_size = None; + sized_null = false; coverage = false; disable_passes = [] } @@ -63,6 +65,8 @@ let has_max_stack_depth () = !instance.max_stack_depth let has_max_generator_size () = !instance.max_generator_size +let is_sized_null () = !instance.sized_null + let is_coverage () = !instance.coverage let has_pass s = not (List.mem String.equal s !instance.disable_passes) diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index b09ecf0b6..67d17b64a 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -13,6 +13,7 @@ type t = exit_fast : bool; max_stack_depth : int option; max_generator_size : int option; + sized_null : bool; coverage : bool; disable_passes : string list } @@ -45,6 +46,8 @@ val has_max_stack_depth : unit -> int option val has_max_generator_size : unit -> int option +val is_sized_null : unit -> bool + val is_coverage : unit -> bool val has_pass : string -> bool From 66e0b92ed42b571dee004f2fd0a6d7145eff0278 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 2 Dec 2024 13:13:28 -0500 Subject: [PATCH 073/148] [CN-Test-Gen] Fix `--coverage` Means that compiler warnings' paths are not from current directory, but test directory instead --- .github/workflows/ci-cn-spec-testing.yml | 2 +- backend/cn/lib/testGeneration/specTests.ml | 138 +++++++++++---------- tests/run-cn-test-gen.sh | 77 +++++++----- 3 files changed, 115 insertions(+), 102 deletions(-) diff --git a/.github/workflows/ci-cn-spec-testing.yml b/.github/workflows/ci-cn-spec-testing.yml index 1827be49e..0bcdb4d74 100644 --- a/.github/workflows/ci-cn-spec-testing.yml +++ b/.github/workflows/ci-cn-spec-testing.yml @@ -31,7 +31,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt-get install build-essential libgmp-dev z3 opam cmake + sudo apt-get install build-essential libgmp-dev z3 opam cmake lcov - name: Restore cached opam id: cache-opam-restore diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 1057ff1b0..750f1cb06 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -365,9 +365,9 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = ^^ string "exit 1") ^^ hardline) ^^ twice hardline - ^^ string "TEST_DIR=" - ^^ string (Filename.dirname (Filename.concat output_dir "junk")) + ^^ string ("TEST_DIR=" ^ Filename.dirname (Filename.concat output_dir "junk")) ^^ hardline + ^^ string "pushd $TEST_DIR > /dev/null" ^^ twice hardline ^^ string "# Compile" ^^ hardline @@ -380,8 +380,8 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = "-c"; "\"-I${RUNTIME_PREFIX}/include/\""; "-o"; - "\"${TEST_DIR}/" ^ Filename.chop_extension test_file ^ ".o\""; - "\"${TEST_DIR}/" ^ test_file ^ "\""; + "\"./" ^ Filename.chop_extension test_file ^ ".o\""; + "\"./" ^ test_file ^ "\""; (if Config.is_coverage () then "--coverage;" else ";"); "then" ] @@ -407,8 +407,8 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = "-g"; "\"-I${RUNTIME_PREFIX}/include\""; "-o"; - "\"${TEST_DIR}/tests.out\""; - "${TEST_DIR}/" ^ Filename.chop_extension test_file ^ ".o"; + "\"./tests.out\""; + Filename.chop_extension test_file ^ ".o"; "\"${RUNTIME_PREFIX}/libcn.a\""; (if Config.is_coverage () then "--coverage;" else ";"); "then" @@ -432,7 +432,7 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = separate_map space string - ([ "\"${TEST_DIR}/tests.out\"" ] + ([ "./tests.out" ] @ (Config.has_null_in_every () |> Option.map (fun null_in_every -> [ "--null-in-every"; string_of_int null_in_every ]) @@ -474,67 +474,71 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = []) in cmd - ^^ semi ^^ hardline - ^^ - if Config.is_coverage () then - string "# Coverage" - ^^ hardline - ^^ string "test_exit_code=$? # Save tests exit code for later" - ^^ twice hardline - ^^ string "pushd \"${TEST_DIR}\"" - ^^ twice hardline - ^^ string ("if gcov \"" ^ test_file ^ "\"; then") - ^^ nest 4 (hardline ^^ string "echo \"Recorded coverage via gcov.\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to record coverage.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ twice hardline - ^^ string "if lcov --capture --directory . --output-file coverage.info; then" - ^^ nest 4 (hardline ^^ string "echo \"Collected coverage via lcov.\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to collect coverage.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ twice hardline - ^^ separate_map - space - string - [ "if"; "genhtml"; "--output-directory"; "html"; "\"coverage.info\";"; "then" ] - ^^ nest - 4 - (hardline - ^^ string "echo \"Generated HTML report at \\\"${TEST_DIR}/html/\\\".\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to generate HTML report.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ twice hardline - ^^ string "popd" - ^^ twice hardline - ^^ string "exit \"$test_exit_code\"" - ^^ hardline - else - empty + ^^ string "test_exit_code=$? # Save tests exit code for later" + ^^ twice hardline + ^^ hardline + ^^ (if Config.is_coverage () then + hardline + ^^ string "# Coverage" + ^^ hardline + ^^ string ("if gcov \"" ^ test_file ^ "\"; then") + ^^ nest 4 (hardline ^^ string "echo \"Recorded coverage via gcov.\"") + ^^ hardline + ^^ string "else" + ^^ nest + 4 + (hardline + ^^ string "printf \"Failed to record coverage.\"" + ^^ hardline + ^^ string "exit 1") + ^^ hardline + ^^ string "fi" + ^^ twice hardline + ^^ string "if lcov --capture --directory . --output-file coverage.info; then" + ^^ nest 4 (hardline ^^ string "echo \"Collected coverage via lcov.\"") + ^^ hardline + ^^ string "else" + ^^ nest + 4 + (hardline + ^^ string "printf \"Failed to collect coverage.\"" + ^^ hardline + ^^ string "exit 1") + ^^ hardline + ^^ string "fi" + ^^ twice hardline + ^^ separate_map + space + string + [ "if"; + "genhtml"; + "--output-directory"; + "html"; + "\"coverage.info\";"; + "then" + ] + ^^ nest + 4 + (hardline + ^^ string "echo \"Generated HTML report at \\\"${TEST_DIR}/html/\\\".\"") + ^^ hardline + ^^ string "else" + ^^ nest + 4 + (hardline + ^^ string "printf \"Failed to generate HTML report.\"" + ^^ hardline + ^^ string "exit 1") + ^^ hardline + ^^ string "fi" + else + empty) + ^^ twice hardline + ^^ string "popd > /dev/null" + ^^ twice hardline + ^^ string "exit $test_exit_code" + ^^ hardline let save ?(perm = 0o666) (output_dir : string) (filename : string) (doc : Pp.document) diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index 4e93c2a3b..8991ffd25 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -27,45 +27,54 @@ function separator() { printf '\n\n' } -# Test each `*.c` file -for TEST in $FILES; do - CLEANUP="rm -rf test/* run_tests.sh;separator" +CONFIGS=("--coverage" "--sized-null") - # Run passing tests - if [[ $TEST == *.pass.c ]]; then - $CN test "$TEST" --output-dir="test" - RET=$? - if [[ "$RET" != 0 ]]; then - echo - echo "$TEST -- Tests failed unexpectedly" - NUM_FAILED=$(($NUM_FAILED + 1)) - FAILED="$FAILED $TEST" - eval "$CLEANUP" - continue - else - echo - echo "$TEST -- Tests passed successfully" +# For each configuration +for CONFIG in ${CONFIGS[@]}; do + separator + echo "Running CI with CLI config \"$CONFIG\"" + separator + + # Test each `*.c` file + for TEST in $FILES; do + CLEANUP="rm -rf test/* run_tests.sh;separator" + + # Run passing tests + if [[ $TEST == *.pass.c ]]; then + $CN test "$TEST" --output-dir="test" $CONFIG + RET=$? + if [[ "$RET" != 0 ]]; then + echo + echo "$TEST -- Tests failed unexpectedly" + NUM_FAILED=$(($NUM_FAILED + 1)) + FAILED="$FAILED $TEST" + eval "$CLEANUP" + continue + else + echo + echo "$TEST -- Tests passed successfully" + fi fi - fi - # Run failing tests - if [[ $TEST == *.fail.c ]]; then - $CN test "$TEST" --output-dir="test" - RET=$? - if [[ "$RET" = 0 ]]; then - echo - echo "$TEST -- Tests passed unexpectedly" - NUM_FAILED=$(($NUM_FAILED + 1)) - FAILED="$FAILED $TEST" - eval "$CLEANUP" - continue - else - echo - echo "$TEST -- Tests failed successfully" + # Run failing tests + if [[ $TEST == *.fail.c ]]; then + $CN test "$TEST" --output-dir="test" $CONFIG + RET=$? + if [[ "$RET" = 0 ]]; then + echo + echo "$TEST -- Tests passed unexpectedly" + NUM_FAILED=$(($NUM_FAILED + 1)) + FAILED="$FAILED $TEST" + eval "$CLEANUP" + continue + else + echo + echo "$TEST -- Tests failed successfully" + fi fi - fi - eval "$CLEANUP" + eval "$CLEANUP" + done done echo 'Done running tests.' From 56f0fa1f677a2c89ff9ddd5cc1487feddc775716 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 3 Dec 2024 14:46:52 -0500 Subject: [PATCH 074/148] [CN-Test-Gen] Random splitting of generator sizes --- backend/cn/bin/main.ml | 8 ++ backend/cn/lib/testGeneration/genCodeGen.ml | 93 +++++++++---- backend/cn/lib/testGeneration/genRuntime.ml | 126 +++++++++++++++--- backend/cn/lib/testGeneration/genRuntime.mli | 9 +- .../cn/lib/testGeneration/testGenConfig.ml | 4 + .../cn/lib/testGeneration/testGenConfig.mli | 3 + runtime/libcn/include/cn-testing/dsl.h | 44 ++++++ tests/run-cn-test-gen.sh | 4 +- 8 files changed, 243 insertions(+), 48 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 74b529ae4..65225febf 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -448,6 +448,7 @@ let run_tests exit_fast max_stack_depth max_generator_size + random_size_splits sized_null coverage disable_passes @@ -516,6 +517,7 @@ let run_tests exit_fast; max_stack_depth; max_generator_size; + random_size_splits; sized_null; coverage; disable_passes @@ -990,6 +992,11 @@ module Testing_flags = struct & info [ "max-generator-size" ] ~doc) + let random_size_splits = + let doc = "Randomly split sizes between recursive generator calls" in + Arg.(value & flag & info [ "random-size-splits" ] ~doc) + + let sized_null = let doc = "Scale the likelihood of [NULL] proportionally for a desired size (1/n for size n)" @@ -1051,6 +1058,7 @@ let testing_cmd = $ Testing_flags.exit_fast $ Testing_flags.max_stack_depth $ Testing_flags.max_generator_size + $ Testing_flags.random_size_splits $ Testing_flags.sized_null $ Testing_flags.coverage $ Testing_flags.disable_passes diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index b84ca2a69..278effae0 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -144,33 +144,33 @@ let rec compile_term | Call { fsym; iargs; oarg_bt; path_vars; sized } -> let sym = GenUtils.get_mangled_name (fsym :: List.map fst iargs) in let es = iargs |> List.map snd |> List.map (fun x -> A.(AilEident x)) in - let es = - List.map - mk_expr - (es - @ A.( - match sized with - | Some 1 -> - [ AilEbinary - ( mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")), - Arithmetic Sub, - mk_expr - (AilEconst (ConstantInteger (IConstant (Z.one, Decimal, None)))) ) - ] - | Some n -> - [ AilEbinary - ( mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")), - Arithmetic Div, - mk_expr - (AilEconst - (ConstantInteger (IConstant (Z.of_int n, Decimal, None)))) ) - ] - | None - when (not (GenBuiltins.is_builtin fsym)) - && (ctx |> List.assoc Sym.equal fsym |> List.hd |> snd).sized -> - [ AilEcall (mk_expr (AilEident (Sym.fresh_named "cn_gen_get_size")), []) ] - | None -> [])) + let sized_call = + A.( + match sized with + | Some (n, _) when n <= 0 -> failwith "Invalid sized call" + | Some (1, _) -> + [ AilEbinary + ( mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")), + Arithmetic Sub, + mk_expr (AilEconst (ConstantInteger (IConstant (Z.one, Decimal, None)))) + ) + ] + | Some (_, sym_size) when TestGenConfig.is_random_size_splits () -> + [ AilEident sym_size ] + | Some (n, _) -> + [ AilEbinary + ( mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")), + Arithmetic Div, + mk_expr + (AilEconst (ConstantInteger (IConstant (Z.of_int n, Decimal, None)))) ) + ] + | None + when (not (GenBuiltins.is_builtin fsym)) + && (ctx |> List.assoc Sym.equal fsym |> List.hd |> snd).sized -> + [ AilEcall (mk_expr (AilEident (Sym.fresh_named "cn_gen_get_size")), []) ] + | None -> []) in + let es = List.map mk_expr (es @ sized_call) in let x = Sym.fresh () in let b = Utils.create_binding x (bt_to_ctype fsym oarg_bt) in let wrap_to_string (sym : Sym.t) = @@ -451,6 +451,47 @@ let rec compile_term ( [ b_map; b_i ] @ b_min @ b_perm @ b_val, s_begin @ s_body @ s_end, mk_expr (AilEident sym_map) ) + | SplitSize { rest; _ } when not (TestGenConfig.is_random_size_splits ()) -> + compile_term sigma ctx name rest + | SplitSize { marker_var; syms; path_vars; last_var; rest } -> + let e_ty = mk_expr (AilEident (Sym.fresh_named (name_of_bt name Memory.size_bt))) in + let e_tmp = mk_expr (AilEident marker_var) in + let e_size = mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")) in + let syms_l = syms |> GR.SymSet.to_seq |> List.of_seq in + let b = + syms_l |> List.map (fun x -> Utils.create_binding x (C.mk_ctype_integer Size_t)) + in + let e_syms = + syms_l |> List.map (fun x -> mk_expr (AilEunary (Address, mk_expr (AilEident x)))) + in + let wrap_to_string (sym : Sym.t) = + let open A in + mk_expr + (AilEcast + ( C.no_qualifiers, + C.pointer_to_char, + mk_expr + (AilEstr (None, [ (Locations.other __LOC__, [ Sym.pp_string sym ]) ])) )) + in + let s = + let open A in + List.map (fun x -> AilSdeclaration [ (x, None) ]) syms_l + @ [ AilSexpr + (mk_expr + (AilEcall + ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_SPLIT_BEGIN")), + [ e_tmp; e_size ] @ e_syms @ [ mk_expr (AilEconst ConstantNull) ] ))); + AilSexpr + (mk_expr + (AilEcall + ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_SPLIT_END")), + [ e_ty; e_tmp; e_size; mk_expr (AilEident last_var) ] + @ List.map wrap_to_string (List.of_seq (GR.SymSet.to_seq path_vars)) + @ [ mk_expr (AilEconst ConstantNull) ] ))) + ] + in + let b', s', e' = compile_term sigma ctx name rest in + (b @ b', s @ s', e') let compile_gen_def diff --git a/backend/cn/lib/testGeneration/genRuntime.ml b/backend/cn/lib/testGeneration/genRuntime.ml index 539080dd2..abe1960ff 100644 --- a/backend/cn/lib/testGeneration/genRuntime.ml +++ b/backend/cn/lib/testGeneration/genRuntime.ml @@ -34,7 +34,7 @@ type term = iargs : (Sym.t * Sym.t) list; oarg_bt : BT.t; path_vars : SymSet.t; - sized : int option + sized : (int * Sym.t) option } | Asgn of { pointer : Sym.t; @@ -73,6 +73,13 @@ type term = inner : term; last_var : Sym.t } + | SplitSize of + { marker_var : Sym.t; + syms : SymSet.t; + path_vars : SymSet.t; + last_var : Sym.t; + rest : term + } [@@deriving eq, ord] let is_return (tm : term) : bool = match tm with Return _ -> true | _ -> false @@ -98,6 +105,8 @@ let rec free_vars_term (tm : term) : SymSet.t = SymSet.remove i (SymSet.union (IT.free_vars_list [ min; max; perm ]) (free_vars_term inner)) + | SplitSize { marker_var = _; syms = _; path_vars = _; last_var = _; rest } -> + free_vars_term rest and free_vars_term_list : term list -> SymSet.t = @@ -138,7 +147,9 @@ let rec pp_term (tm : term) : Pp.document = | Call { fsym; iargs; oarg_bt; path_vars; sized } -> parens (Sym.pp fsym - ^^ optional (fun n -> brackets (int n)) sized + ^^ optional + (fun (n, sym) -> brackets (int n ^^ comma ^^ space ^^ Sym.pp sym)) + sized ^^ parens (nest 2 @@ -242,6 +253,27 @@ let rec pp_term (tm : term) : Pp.document = (IT.pp min ^^ string " <= " ^^ Sym.pp i ^^ string " <= " ^^ IT.pp max) ^^ c_comment (string "backtracks to" ^^ space ^^ Sym.pp last_var)) ^^ braces (c_comment (BT.pp bt) ^^ nest 2 (break 1 ^^ pp_term inner) ^^ break 1) + | SplitSize { marker_var; syms; path_vars; last_var; rest } -> + string "split_size" + ^^ brackets (Sym.pp marker_var) + ^^ parens + (separate_map (comma ^^ space) Sym.pp (syms |> SymSet.to_seq |> List.of_seq)) + ^^ space + ^^ c_comment + (string "backtracks to" + ^^ space + ^^ Sym.pp last_var + ^^ comma + ^^ space + ^^ string "path affected by" + ^^ space + ^^ separate_map + (comma ^^ space) + Sym.pp + (path_vars |> SymSet.to_seq |> List.of_seq)) + ^^ semi + ^^ break 1 + ^^ pp_term rest let nice_names (inputs : SymSet.t) (gt : GT.t) : GT.t = @@ -350,7 +382,10 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = Z.to_int (Z.max Z.one (Z.div w (Z.div (Z.add w_sum (Z.pred max_int)) max_int))) in - List.map (fun (w, gt) -> (f w, aux (choice_var :: vars) path_vars gt)) wgts); + List.map + (fun (w, gt) -> + (f w, aux (choice_var :: vars) (SymSet.add choice_var path_vars) gt)) + wgts); last_var } | Alloc bytes -> Alloc { bytes; sized = false } @@ -510,40 +545,91 @@ module Sizing = struct | Assert { rest; _ } -> aux rest | ITE { t; f; _ } -> max (aux t) (aux f) | Map { inner; _ } -> aux inner + | SplitSize _ -> failwith ("unreachable @ " ^ __LOC__) in aux gr - let size_recursive_calls (syms : SymSet.t) (size : int) (gr : term) : term = - let rec aux (gr : term) : term = + let size_recursive_calls (marker_var : Sym.t) (syms : SymSet.t) (size : int) (gr : term) + : term * SymSet.t + = + let rec aux (gr : term) : term * SymSet.t = match gr with - | Call ({ fsym; _ } as gr) when SymSet.mem fsym syms -> - Call { gr with sized = Some size } - | Uniform _ | Call _ | Return _ -> gr - | Alloc { bytes; sized = _ } -> Alloc { bytes; sized = true } + | Call ({ fsym; path_vars; _ } as gr) when SymSet.mem fsym syms -> + let sym = Sym.fresh () in + let gr' = + if size > 1 && TestGenConfig.is_random_size_splits () then + Call + { gr with + sized = Some (size, sym); + path_vars = SymSet.add marker_var path_vars + } + else + Call { gr with sized = Some (size, sym) } + in + (gr', SymSet.singleton sym) + | Uniform _ | Call _ | Return _ -> (gr, SymSet.empty) + | Alloc { bytes; sized = _ } -> (Alloc { bytes; sized = true }, SymSet.empty) | Pick ({ choices; _ } as gr) -> - Pick { gr with choices = choices |> List.map_snd aux } - | Asgn ({ rest; _ } as gr) -> Asgn { gr with rest = aux rest } + let choices, syms = + choices + |> List.map (fun (w, gr) -> + let gr, syms = aux gr in + ((w, gr), syms)) + |> List.split + in + (Pick { gr with choices }, List.fold_left SymSet.union SymSet.empty syms) + | Asgn ({ rest; _ } as gr) -> + let rest, syms = aux rest in + (Asgn { gr with rest }, syms) | Let ({ value; rest; _ } as gr) -> - Let { gr with value = aux value; rest = aux rest } - | Assert ({ rest; _ } as gr) -> Assert { gr with rest = aux rest } - | ITE ({ t; f; _ } as gr) -> ITE { gr with t = aux t; f = aux f } - | Map ({ inner; _ } as gr) -> Map { gr with inner = aux inner } + let value, syms = aux value in + let rest, syms' = aux rest in + (Let { gr with value; rest }, SymSet.union syms syms') + | Assert ({ rest; _ } as gr) -> + let rest, syms = aux rest in + (Assert { gr with rest }, syms) + | ITE ({ t; f; _ } as gr) -> + let t, syms = aux t in + let f, syms' = aux f in + (ITE { gr with t; f }, SymSet.union syms syms') + | Map ({ inner; _ } as gr) -> + let inner, syms = aux inner in + (Map { gr with inner }, syms) + | SplitSize _ -> failwith ("unreachable @ " ^ __LOC__) in aux gr let transform_gr (syms : SymSet.t) (gr : term) : term = - let rec aux (gr : term) : term = + let rec aux (path_vars : SymSet.t) (gr : term) : term = match gr with - | ITE { bt; cond; t; f } -> ITE { bt; cond; t = aux t; f = aux f } + | ITE { bt; cond; t; f } -> + let path_vars = SymSet.union path_vars (IT.free_vars cond) in + ITE { bt; cond; t = aux path_vars t; f = aux path_vars f } | Pick { bt; choice_var; choices; last_var } -> - Pick { bt; choice_var; choices = List.map_snd aux choices; last_var } + Pick + { bt; + choice_var; + choices = List.map_snd (aux (SymSet.add choice_var path_vars)) choices; + last_var + } | _ -> let count = count_recursive_calls syms gr in - size_recursive_calls syms count gr + let marker_var = Sym.fresh () in + let gr, syms = size_recursive_calls marker_var syms count gr in + if count > 1 then + SplitSize + { marker_var; + syms; + last_var = Sym.fresh_named "bennet"; + path_vars; + rest = gr + } + else + gr in - aux gr + aux SymSet.empty gr let transform_def diff --git a/backend/cn/lib/testGeneration/genRuntime.mli b/backend/cn/lib/testGeneration/genRuntime.mli index d5269cde3..b924008b8 100644 --- a/backend/cn/lib/testGeneration/genRuntime.mli +++ b/backend/cn/lib/testGeneration/genRuntime.mli @@ -27,7 +27,7 @@ type term = iargs : (Sym.t * Sym.t) list; oarg_bt : BT.t; path_vars : SymSet.t; - sized : int option + sized : (int * Sym.t) option } | Asgn of { pointer : Sym.t; @@ -66,6 +66,13 @@ type term = inner : term; last_var : Sym.t } + | SplitSize of + { marker_var : Sym.t; + syms : SymSet.t; + path_vars : SymSet.t; + last_var : Sym.t; + rest : term + } [@@deriving eq, ord] val free_vars_term : term -> SymSet.t diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index 1c086ac9d..1b7a617e0 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -13,6 +13,7 @@ type t = exit_fast : bool; max_stack_depth : int option; max_generator_size : int option; + random_size_splits : bool; sized_null : bool; coverage : bool; disable_passes : string list @@ -31,6 +32,7 @@ let default = exit_fast = false; max_stack_depth = None; max_generator_size = None; + random_size_splits = false; sized_null = false; coverage = false; disable_passes = [] @@ -65,6 +67,8 @@ let has_max_stack_depth () = !instance.max_stack_depth let has_max_generator_size () = !instance.max_generator_size +let is_random_size_splits () = !instance.random_size_splits + let is_sized_null () = !instance.sized_null let is_coverage () = !instance.coverage diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 67d17b64a..5fae4a2b3 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -13,6 +13,7 @@ type t = exit_fast : bool; max_stack_depth : int option; max_generator_size : int option; + random_size_splits : bool; sized_null : bool; coverage : bool; disable_passes : string list @@ -46,6 +47,8 @@ val has_max_stack_depth : unit -> int option val has_max_generator_size : unit -> int option +val is_random_size_splits : unit -> bool + val is_sized_null : unit -> bool val is_coverage : unit -> bool diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index 4c98ef901..98945643a 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -237,5 +237,49 @@ } \ urn_free(tmp##_urn); \ +#define CN_GEN_SPLIT_BEGIN(tmp, size, ...) \ + alloc_checkpoint tmp##_checkpoint = alloc_save_checkpoint(); \ + void *tmp##_alloc_checkpoint = cn_gen_alloc_save(); \ + void *tmp##_ownership_checkpoint = cn_gen_ownership_save(); \ + cn_label_##tmp##_gen: \ + { \ + size_t* vars[] = { __VA_ARGS__ }; \ + int count = 0; \ + for (int i = 0; vars[i] != NULL; i++) { \ + count += 1; \ + } + +#define CN_GEN_SPLIT_END(ty, tmp, size, last_var, ...) \ + if (count >= size) { \ + cn_gen_backtrack_depth_exceeded(); \ + char* toAdd[] = { __VA_ARGS__, NULL }; \ + cn_gen_backtrack_relevant_add_many(toAdd); \ + goto cn_label_##last_var##_backtrack; \ + } \ + size_t used = 0; \ + for (int i = 0; i < count - 1; i++) { \ + int left = size - (count - i) + 1 - used; \ + ty* one = convert_to_##ty(1); \ + ty* bound = convert_to_##ty(left + 1); \ + ty* rnd = cn_gen_range_##ty(one, bound); \ + *vars[i] = convert_from_##ty(rnd); \ + used += convert_from_##ty(rnd); \ + } \ + *vars[count - 1] = size - 1 - used; \ + } \ + if (0) { \ + cn_label_##tmp##_backtrack: \ + free_after(tmp##_checkpoint); \ + cn_gen_alloc_restore(tmp##_alloc_checkpoint); \ + cn_gen_ownership_restore(tmp##_ownership_checkpoint); \ + if (cn_gen_backtrack_relevant_contains(#tmp)) { \ + cn_gen_backtrack_reset(); \ + goto cn_label_##tmp##_gen; \ + } else { \ + goto cn_label_##last_var##_backtrack; \ + } \ + } + + #endif // CN_GEN_DSL_H diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index 8991ffd25..89a15942b 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -27,7 +27,7 @@ function separator() { printf '\n\n' } -CONFIGS=("--coverage" "--sized-null") +CONFIGS=("--coverage" "--sized-null" "--random-size-splits") # For each configuration for CONFIG in ${CONFIGS[@]}; do @@ -35,6 +35,8 @@ for CONFIG in ${CONFIGS[@]}; do echo "Running CI with CLI config \"$CONFIG\"" separator + CONFIG="$CONFIG --max-generator-size=10" + # Test each `*.c` file for TEST in $FILES; do CLEANUP="rm -rf test/* run_tests.sh;separator" From eb595be180c8ae8d82005aed040cbf249367a495 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 3 Dec 2024 14:54:55 -0500 Subject: [PATCH 075/148] [CN-Test-Gen] Set max stack depth failures --- backend/cn/bin/main.ml | 11 +++++++++++ backend/cn/lib/testGeneration/specTests.ml | 14 +++++++++----- backend/cn/lib/testGeneration/testGenConfig.ml | 4 ++++ backend/cn/lib/testGeneration/testGenConfig.mli | 3 +++ runtime/libcn/include/cn-testing/dsl.h | 12 +++++++----- runtime/libcn/include/cn-testing/size.h | 3 +++ runtime/libcn/src/cn-testing/size.c | 12 +++++++++++- runtime/libcn/src/cn-testing/test.c | 3 +++ tests/run-cn-test-gen.sh | 2 +- 9 files changed, 52 insertions(+), 12 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 65225febf..79618174f 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -447,6 +447,7 @@ let run_tests until_timeout exit_fast max_stack_depth + allowed_depth_failures max_generator_size random_size_splits sized_null @@ -516,6 +517,7 @@ let run_tests until_timeout; exit_fast; max_stack_depth; + allowed_depth_failures; max_generator_size; random_size_splits; sized_null; @@ -984,6 +986,14 @@ module Testing_flags = struct & info [ "max-stack-depth" ] ~doc) + let allowed_depth_failures = + let doc = "Maximum stack depth failures before discarding an attempt" in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.allowed_depth_failures + & info [ "allowed-depth-failures" ] ~doc) + + let max_generator_size = let doc = "Maximum size for generated values" in Arg.( @@ -1057,6 +1067,7 @@ let testing_cmd = $ Testing_flags.until_timeout $ Testing_flags.exit_fast $ Testing_flags.max_stack_depth + $ Testing_flags.allowed_depth_failures $ Testing_flags.max_generator_size $ Testing_flags.random_size_splits $ Testing_flags.sized_null diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 750f1cb06..3886c343e 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -467,11 +467,15 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = [ "--max-generator-size"; string_of_int max_generator_size ]) |> Option.to_list |> List.flatten) - @ - if Config.is_sized_null () then - [ "--sized-null" ] - else - []) + @ (if Config.is_sized_null () then + [ "--sized-null" ] + else + []) + @ (Config.has_allowed_depth_failures () + |> Option.map (fun allowed_depth_failures -> + [ "--allowed-depth-failures"; string_of_int allowed_depth_failures ]) + |> Option.to_list + |> List.flatten)) in cmd ^^ hardline diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index 1b7a617e0..a89316a73 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -12,6 +12,7 @@ type t = until_timeout : int option; exit_fast : bool; max_stack_depth : int option; + allowed_depth_failures : int option; max_generator_size : int option; random_size_splits : bool; sized_null : bool; @@ -31,6 +32,7 @@ let default = until_timeout = None; exit_fast = false; max_stack_depth = None; + allowed_depth_failures = None; max_generator_size = None; random_size_splits = false; sized_null = false; @@ -65,6 +67,8 @@ let is_exit_fast () = !instance.exit_fast let has_max_stack_depth () = !instance.max_stack_depth +let has_allowed_depth_failures () = !instance.allowed_depth_failures + let has_max_generator_size () = !instance.max_generator_size let is_random_size_splits () = !instance.random_size_splits diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 5fae4a2b3..a27771a68 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -12,6 +12,7 @@ type t = until_timeout : int option; exit_fast : bool; max_stack_depth : int option; + allowed_depth_failures : int option; max_generator_size : int option; random_size_splits : bool; sized_null : bool; @@ -45,6 +46,8 @@ val is_exit_fast : unit -> bool val has_max_stack_depth : unit -> int option +val has_allowed_depth_failures : unit -> int option + val has_max_generator_size : unit -> int option val is_random_size_splits : unit -> bool diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index 98945643a..07b38d742 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -27,11 +27,13 @@ } \ cn_gen_increment_depth(); \ if (size <= 0 || cn_gen_depth() == cn_gen_max_depth()) { \ - static int backtracks; \ - backtracks++; \ - if (backtracks >= 100) { \ - cn_gen_backtrack_assert_failure(); \ - goto cn_label_bennet_backtrack; \ + if (cn_gen_get_depth_failures_allowed() != UINT16_MAX) { \ + static int backtracks; \ + backtracks++; \ + if (backtracks >= cn_gen_get_depth_failures_allowed()) { \ + cn_gen_backtrack_assert_failure(); \ + goto cn_label_bennet_backtrack; \ + } \ } \ cn_gen_backtrack_depth_exceeded(); \ goto cn_label_bennet_backtrack; \ diff --git a/runtime/libcn/include/cn-testing/size.h b/runtime/libcn/include/cn-testing/size.h index 55b645c96..13c69d3c0 100644 --- a/runtime/libcn/include/cn-testing/size.h +++ b/runtime/libcn/include/cn-testing/size.h @@ -12,3 +12,6 @@ uint16_t cn_gen_max_depth(); void cn_gen_set_max_depth(uint16_t msd); void cn_gen_increment_depth(); void cn_gen_decrement_depth(); + +void cn_gen_set_depth_failures_allowed(uint16_t allowed); +uint16_t cn_gen_get_depth_failures_allowed(); diff --git a/runtime/libcn/src/cn-testing/size.c b/runtime/libcn/src/cn-testing/size.c index 3e459e2a2..c8ceb173f 100644 --- a/runtime/libcn/src/cn-testing/size.c +++ b/runtime/libcn/src/cn-testing/size.c @@ -41,4 +41,14 @@ void cn_gen_increment_depth() { void cn_gen_decrement_depth() { stack_depth--; -} \ No newline at end of file +} + +static uint16_t depth_failures_allowed = UINT16_MAX; + +void cn_gen_set_depth_failures_allowed(uint16_t allowed) { + depth_failures_allowed = allowed; +} + +uint16_t cn_gen_get_depth_failures_allowed() { + return depth_failures_allowed; +} diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index 0111ad01f..fe6bd8229 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -100,6 +100,9 @@ int cn_test_main(int argc, char* argv[]) { } else if (strcmp("--sized-null", arg) == 0) { set_sized_null(); + } + else if (strcmp("--allowed-depth-failures", arg) == 0) { + cn_gen_set_depth_failures_allowed(strtoul(argv[i + 1], NULL, 10)); i++; } } diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index 89a15942b..a915847a8 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -35,7 +35,7 @@ for CONFIG in ${CONFIGS[@]}; do echo "Running CI with CLI config \"$CONFIG\"" separator - CONFIG="$CONFIG --max-generator-size=10" + CONFIG="$CONFIG --max-generator-size=10 --allowed-depth-failures=100" # Test each `*.c` file for TEST in $FILES; do From dc6bf28f780762697838ef649b2dd5e018b5f982 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 3 Dec 2024 16:17:11 -0500 Subject: [PATCH 076/148] [CN-Test-Gen] Control backtracks from size splits --- backend/cn/bin/main.ml | 14 ++++++++++++++ backend/cn/lib/testGeneration/specTests.ml | 7 +++++++ backend/cn/lib/testGeneration/testGenConfig.ml | 4 ++++ backend/cn/lib/testGeneration/testGenConfig.mli | 3 +++ runtime/libcn/include/cn-testing/dsl.h | 9 ++++++++- runtime/libcn/include/cn-testing/size.h | 3 +++ runtime/libcn/src/cn-testing/size.c | 10 ++++++++++ runtime/libcn/src/cn-testing/test.c | 4 ++++ tests/run-cn-test-gen.sh | 2 +- 9 files changed, 54 insertions(+), 2 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 79618174f..9a3b9a4cd 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -450,6 +450,7 @@ let run_tests allowed_depth_failures max_generator_size random_size_splits + allowed_size_split_backtracks sized_null coverage disable_passes @@ -520,6 +521,7 @@ let run_tests allowed_depth_failures; max_generator_size; random_size_splits; + allowed_size_split_backtracks; sized_null; coverage; disable_passes @@ -1007,6 +1009,17 @@ module Testing_flags = struct Arg.(value & flag & info [ "random-size-splits" ] ~doc) + let allowed_size_split_backtracks = + let doc = + "Set the maximum attempts to split up a generator's size (between recursive calls) \ + before backtracking further, during input generation" + in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.allowed_size_split_backtracks + & info [ "allowed-size-split-backtracks" ] ~doc) + + let sized_null = let doc = "Scale the likelihood of [NULL] proportionally for a desired size (1/n for size n)" @@ -1070,6 +1083,7 @@ let testing_cmd = $ Testing_flags.allowed_depth_failures $ Testing_flags.max_generator_size $ Testing_flags.random_size_splits + $ Testing_flags.allowed_size_split_backtracks $ Testing_flags.sized_null $ Testing_flags.coverage $ Testing_flags.disable_passes diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 3886c343e..4fa7c7381 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -475,6 +475,13 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = |> Option.map (fun allowed_depth_failures -> [ "--allowed-depth-failures"; string_of_int allowed_depth_failures ]) |> Option.to_list + |> List.flatten) + @ (Config.has_allowed_size_split_backtracks () + |> Option.map (fun allowed_size_split_backtracks -> + [ "--allowed-size-split-backtracks"; + string_of_int allowed_size_split_backtracks + ]) + |> Option.to_list |> List.flatten)) in cmd diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index a89316a73..08f9c9b5f 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -15,6 +15,7 @@ type t = allowed_depth_failures : int option; max_generator_size : int option; random_size_splits : bool; + allowed_size_split_backtracks : int option; sized_null : bool; coverage : bool; disable_passes : string list @@ -35,6 +36,7 @@ let default = allowed_depth_failures = None; max_generator_size = None; random_size_splits = false; + allowed_size_split_backtracks = None; sized_null = false; coverage = false; disable_passes = [] @@ -73,6 +75,8 @@ let has_max_generator_size () = !instance.max_generator_size let is_random_size_splits () = !instance.random_size_splits +let has_allowed_size_split_backtracks () = !instance.allowed_size_split_backtracks + let is_sized_null () = !instance.sized_null let is_coverage () = !instance.coverage diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index a27771a68..4ef4789ea 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -15,6 +15,7 @@ type t = allowed_depth_failures : int option; max_generator_size : int option; random_size_splits : bool; + allowed_size_split_backtracks : int option; sized_null : bool; coverage : bool; disable_passes : string list @@ -52,6 +53,8 @@ val has_max_generator_size : unit -> int option val is_random_size_splits : unit -> bool +val has_allowed_size_split_backtracks : unit -> int option + val is_sized_null : unit -> bool val is_coverage : unit -> bool diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index 07b38d742..bb458b599 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -240,6 +240,7 @@ urn_free(tmp##_urn); \ #define CN_GEN_SPLIT_BEGIN(tmp, size, ...) \ + int tmp##_backtracks = cn_gen_get_size_split_backtracks_allowed(); \ alloc_checkpoint tmp##_checkpoint = alloc_save_checkpoint(); \ void *tmp##_alloc_checkpoint = cn_gen_alloc_save(); \ void *tmp##_ownership_checkpoint = cn_gen_ownership_save(); \ @@ -254,7 +255,7 @@ #define CN_GEN_SPLIT_END(ty, tmp, size, last_var, ...) \ if (count >= size) { \ cn_gen_backtrack_depth_exceeded(); \ - char* toAdd[] = { __VA_ARGS__, NULL }; \ + char* toAdd[] = { __VA_ARGS__ }; \ cn_gen_backtrack_relevant_add_many(toAdd); \ goto cn_label_##last_var##_backtrack; \ } \ @@ -275,6 +276,12 @@ cn_gen_alloc_restore(tmp##_alloc_checkpoint); \ cn_gen_ownership_restore(tmp##_ownership_checkpoint); \ if (cn_gen_backtrack_relevant_contains(#tmp)) { \ + char* toAdd[] = { __VA_ARGS__ }; \ + cn_gen_backtrack_relevant_add_many(toAdd); \ + if (tmp##_backtracks <= 0) { \ + goto cn_label_##last_var##_backtrack; \ + } \ + tmp##_backtracks--; \ cn_gen_backtrack_reset(); \ goto cn_label_##tmp##_gen; \ } else { \ diff --git a/runtime/libcn/include/cn-testing/size.h b/runtime/libcn/include/cn-testing/size.h index 13c69d3c0..6375724c2 100644 --- a/runtime/libcn/include/cn-testing/size.h +++ b/runtime/libcn/include/cn-testing/size.h @@ -15,3 +15,6 @@ void cn_gen_decrement_depth(); void cn_gen_set_depth_failures_allowed(uint16_t allowed); uint16_t cn_gen_get_depth_failures_allowed(); + +void cn_gen_set_size_split_backtracks_allowed(uint16_t allowed); +uint16_t cn_gen_get_size_split_backtracks_allowed(); diff --git a/runtime/libcn/src/cn-testing/size.c b/runtime/libcn/src/cn-testing/size.c index c8ceb173f..9945385ab 100644 --- a/runtime/libcn/src/cn-testing/size.c +++ b/runtime/libcn/src/cn-testing/size.c @@ -52,3 +52,13 @@ void cn_gen_set_depth_failures_allowed(uint16_t allowed) { uint16_t cn_gen_get_depth_failures_allowed() { return depth_failures_allowed; } + +static uint16_t size_split_backtracks_allowed = 0; + +void cn_gen_set_size_split_backtracks_allowed(uint16_t allowed) { + size_split_backtracks_allowed = allowed; +} + +uint16_t cn_gen_get_size_split_backtracks_allowed() { + return size_split_backtracks_allowed; +} diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index fe6bd8229..8e2d5342a 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -105,6 +105,10 @@ int cn_test_main(int argc, char* argv[]) { cn_gen_set_depth_failures_allowed(strtoul(argv[i + 1], NULL, 10)); i++; } + else if (strcmp("--allowed-size-split-backtracks", arg) == 0) { + cn_gen_set_size_split_backtracks_allowed(strtoul(argv[i + 1], NULL, 10)); + i++; + } } if (interactive) { diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index a915847a8..a1f28258e 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -27,7 +27,7 @@ function separator() { printf '\n\n' } -CONFIGS=("--coverage" "--sized-null" "--random-size-splits") +CONFIGS=("--coverage" "--sized-null" "--random-size-splits" "--random-size-splits --allowed-size-split-backtracks=10") # For each configuration for CONFIG in ${CONFIGS[@]}; do From 9805673ee2ea06bc82c62fe058a7f0b4989bbe5d Mon Sep 17 00:00:00 2001 From: Vadim Zaliva Date: Thu, 5 Dec 2024 13:30:15 -0800 Subject: [PATCH 077/148] fixed Coq version (it does not compile with 8.19) --- cerberus-cheri.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cerberus-cheri.opam b/cerberus-cheri.opam index ef5093354..301ed6044 100644 --- a/cerberus-cheri.opam +++ b/cerberus-cheri.opam @@ -35,7 +35,7 @@ depends: [ "ounit2" "ppx_deriving" "zarith" - "coq" {>= "8.18.0"} + "coq" {= "8.18.0"} "coq-bbv" {>= "1.3" & <= "1.4"} "coq-sail-stdpp" "coq-ext-lib" From 36582a607c41fbe3cad5c9648248ca5f750a5087 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 6 Dec 2024 13:26:11 +0000 Subject: [PATCH 078/148] add command line flag to optionally disable learning constraints from resources (#742) --- backend/cn/bin/main.ml | 7 +++++++ backend/cn/lib/resources.ml | 6 +++++- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 9a3b9a4cd..608c8e4de 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -282,6 +282,7 @@ let verify quiet no_inherit_loc magic_comment_char_dollar + disable_resource_derived_constraints = if json then ( if debug_level > 0 then @@ -309,6 +310,7 @@ let verify Check.fail_fast := fail_fast; Diagnostics.diag_string := diag; WellTyped.use_ity := not no_use_ity; + Resources.disable_resource_derived_constraints := disable_resource_derived_constraints; with_well_formedness_check (* CLI arguments *) ~filename ~macros @@ -760,6 +762,10 @@ module Verify_flags = struct let output_dir = let doc = "directory in which to output state files" in Arg.(value & opt (some string) None & info [ "output-dir" ] ~docv:"FILE" ~doc) + + let disable_resource_derived_constraints = + let doc = "disable resource-derived constraints" in + Arg.(value & flag & info [ "disable-resource-derived-constraints" ] ~doc) end module Executable_spec_flags = struct @@ -871,6 +877,7 @@ let verify_t : unit Term.t = $ Verify_flags.quiet $ Common_flags.no_inherit_loc $ Common_flags.magic_comment_char_dollar + $ Verify_flags.disable_resource_derived_constraints let verify_cmd = diff --git a/backend/cn/lib/resources.ml b/backend/cn/lib/resources.ml index 6db544214..3888cf75c 100644 --- a/backend/cn/lib/resources.ml +++ b/backend/cn/lib/resources.ml @@ -75,5 +75,9 @@ let derived_lc2 (resource, _) (resource', _) = | _ -> [] +let disable_resource_derived_constraints = ref false + let pointer_facts ~new_resource ~old_resources = - derived_lc1 new_resource @ List.concat_map (derived_lc2 new_resource) old_resources + if !disable_resource_derived_constraints + then [] + else derived_lc1 new_resource @ List.concat_map (derived_lc2 new_resource) old_resources From 6029b764df206635ca6b4811092428e373e07c4b Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 6 Dec 2024 13:37:29 +0000 Subject: [PATCH 079/148] fix formatting (#743) --- backend/cn/bin/main.ml | 1 + backend/cn/lib/resources.ml | 7 ++++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 608c8e4de..cf47a390b 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -763,6 +763,7 @@ module Verify_flags = struct let doc = "directory in which to output state files" in Arg.(value & opt (some string) None & info [ "output-dir" ] ~docv:"FILE" ~doc) + let disable_resource_derived_constraints = let doc = "disable resource-derived constraints" in Arg.(value & flag & info [ "disable-resource-derived-constraints" ] ~doc) diff --git a/backend/cn/lib/resources.ml b/backend/cn/lib/resources.ml index 3888cf75c..bfd47f2f1 100644 --- a/backend/cn/lib/resources.ml +++ b/backend/cn/lib/resources.ml @@ -78,6 +78,7 @@ let derived_lc2 (resource, _) (resource', _) = let disable_resource_derived_constraints = ref false let pointer_facts ~new_resource ~old_resources = - if !disable_resource_derived_constraints - then [] - else derived_lc1 new_resource @ List.concat_map (derived_lc2 new_resource) old_resources + if !disable_resource_derived_constraints then + [] + else + derived_lc1 new_resource @ List.concat_map (derived_lc2 new_resource) old_resources From fe99f7d16f5dd1a8fdbb798de062c6d962750ecb Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 6 Dec 2024 17:44:49 +0000 Subject: [PATCH 080/148] tentatively tweak z3 solver parameter, as suggested by Can C (#744) This makes one larger in-progress CN proof almost twice as fast. Tentatively putting this here to see the affect on the CI benchmarks. --- backend/cn/lib/simple_smt.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/backend/cn/lib/simple_smt.ml b/backend/cn/lib/simple_smt.ml index 50572d1db..7bd92dd68 100644 --- a/backend/cn/lib/simple_smt.ml +++ b/backend/cn/lib/simple_smt.ml @@ -901,5 +901,5 @@ let cvc5 : solver_config = let z3 : solver_config = (* let params = [ ("sat.smt", "true") ] in *) - let params = [] in + let params = [ ("smt.relevancy", "0") ] in { exe = "z3"; opts = [ "-in"; "-smt2" ]; params; exts = Z3; log = quiet_log } From 3a7897a9f9e0faf2748ba8ddd4142535b87ae8f9 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 3 Dec 2024 13:47:08 +0000 Subject: [PATCH 081/148] CN VIP: Clarify tests Some of the tests rely on ignoring the (demonic) address allocation non-determinism which means that technically that have UB but in practice they are there to exercise particular bits of the memory object model. --- tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c | 7 ++++++- tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c | 7 ++++++- tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c | 5 +++++ .../provenance_basic_using_uintptr_t_auto_yx.annot.c | 5 +++++ .../provenance_basic_using_uintptr_t_global_yx.annot.c | 5 +++++ .../provenance_equality_uintptr_t_auto_yx.pass.c | 5 +++++ .../provenance_equality_uintptr_t_global_yx.pass.c | 5 +++++ tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c | 5 +++++ 8 files changed, 42 insertions(+), 2 deletions(-) diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c index 625f1cbab..88e1fb1c8 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c +++ b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c @@ -6,7 +6,7 @@ #include "cn_lemmas.h" void f(uintptr_t i) { int j=5; - /*@ apply assert_equal(i, (u64)&j); @*/ + /*CN_VIP*//*@ apply assert_equal(i, (u64)&j); @*/ #if defined(ANNOT) int *p = copy_alloc_id(i, &j); #else @@ -20,3 +20,8 @@ int main() { uintptr_t j = ADDRESS_PFI_1I; f(j); } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic). +// I emulate the same behaviour by asserting the addresses are equal. diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c index 61ddda767..0a2208fe1 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c @@ -7,7 +7,7 @@ void f(uintptr_t i) { int j=5; uintptr_t k = (uintptr_t)&j; - /*@ apply assert_equal(i, k); @*/ + /*CN_VIP*//*@ apply assert_equal(i, k); @*/ #if defined(ANNOT) int *p = copy_alloc_id(i, &j); #else @@ -21,3 +21,8 @@ int main() { uintptr_t j = ADDRESS_PFI_1I; f(j); } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are equal. diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c index f7d60a1a6..6a3eb7622 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c @@ -22,3 +22,8 @@ int main() { uintptr_t j = ADDRESS_PFI_1IG; f(j); } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are equal. diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c index 367d9aa76..1a0f644f5 100644 --- a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c @@ -39,3 +39,8 @@ int main() { /*CN_VIP*//*@ assert(x == 1i32 && y == 11i32 && *p == 11i32 && *q == 11i32); @*/ } } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are adjacent. diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c index 2323bb81b..a303f414b 100644 --- a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c @@ -39,3 +39,8 @@ int main() /*CN_VIP*//*@ assert(x == 1i32 && y == 11i32 && *p == 11i32 && *q == 11i32); @*/ } } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are adjacent. diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c index 3f9b7f91f..817a07f95 100644 --- a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c +++ b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c @@ -13,3 +13,8 @@ int main() { /*CN_VIP*//*@ assert (b == 1u8); @*/ return 0; } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are adjacent. diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c index ca27e4105..4fdf1b27d 100644 --- a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c +++ b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c @@ -13,3 +13,8 @@ int main() { /*CN_VIP*//*@ assert (b == 1u8); @*/ return 0; } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are adjacent. diff --git a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c index e2c3f3731..5641b3951 100644 --- a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c +++ b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c @@ -32,3 +32,8 @@ int main() /*CN_VIP*//*@ assert(x == 11i32 && *p == 11i32 && *q == 11i32); @*/ } } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are equal. From 3618709d9ac7cd40cc709ee294bfe83271f6a617 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 10 Dec 2024 06:38:44 -0500 Subject: [PATCH 082/148] [CN-Test-Gen] Note if error comes from cn-exec (#734) --- backend/cn/bin/main.ml | 80 +++++++++++++++++++++++++++--------------- 1 file changed, 51 insertions(+), 29 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index cf47a390b..de5f2ea9f 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -342,6 +342,19 @@ let verify Typing.run_from_pause check paused) +let handle_error_with_user_guidance ~(label : string) (e : exn) : unit = + let msg = Printexc.to_string e in + let stack = Printexc.get_backtrace () in + Printf.eprintf "cn: internal error, uncaught exception:\n %s\n" msg; + let lines = String.split_on_char '\n' stack in + List.iter (fun line -> Printf.eprintf " %s\n" line) lines; + Printf.eprintf + "Issues can be made at https://github.com/rems-project/cerberus/issues.\n"; + Printf.eprintf "Prefix your issue with \"[%s]\". " label; + Printf.eprintf "Check that there isn't already one for this error.\n"; + exit 1 + + let generate_executable_specs filename macros @@ -404,16 +417,19 @@ let generate_executable_specs ~f:(fun ~prog5 ~ail_prog ~statement_locs ~paused:_ -> Cerb_colour.without_colour (fun () -> - Executable_spec.main - ~without_ownership_checking - ~with_test_gen - ~copy_source_dir - filename - ail_prog - output_decorated - output_decorated_dir - prog5 - statement_locs; + (try + Executable_spec.main + ~without_ownership_checking + ~with_test_gen + ~copy_source_dir + filename + ail_prog + output_decorated + output_decorated_dir + prog5 + statement_locs + with + | e -> handle_error_with_user_guidance ~label:"CN-Exec" e); Resultat.return ()) ()) @@ -489,8 +505,8 @@ let run_tests Option.is_some inst.internal) |> List.is_empty then ( - print_endline "No testable functions, aborting"; - exit 1); + print_endline "No testable functions, trivially passing"; + exit 0); if not (Sys.file_exists output_dir) then ( print_endline ("Directory \"" ^ output_dir ^ "\" does not exist."); Sys.mkdir output_dir 0o777; @@ -498,16 +514,19 @@ let run_tests ("Created directory \"" ^ output_dir ^ "\" with full permissions.")); let _, sigma = ail_prog in Cn_internal_to_ail.augment_record_map (BaseTypes.Record []); - Executable_spec.main - ~without_ownership_checking - ~with_test_gen:true - ~copy_source_dir:false - filename - ail_prog - None - (Some output_dir) - prog5 - statement_locs; + (try + Executable_spec.main + ~without_ownership_checking + ~with_test_gen:true + ~copy_source_dir:false + filename + ail_prog + None + (Some output_dir) + prog5 + statement_locs + with + | e -> handle_error_with_user_guidance ~label:"CN-Exec" e); let config : TestGeneration.config = { num_samples; max_backtracks; @@ -529,13 +548,16 @@ let run_tests disable_passes } in - TestGeneration.run - ~output_dir - ~filename - ~without_ownership_checking - config - sigma - prog5; + (try + TestGeneration.run + ~output_dir + ~filename + ~without_ownership_checking + config + sigma + prog5 + with + | e -> handle_error_with_user_guidance ~label:"CN-Test-Gen" e); if not dont_run then Unix.execv (Filename.concat output_dir "run_tests.sh") (Array.of_list [])) (); From d5c47f3fdf16c6ba0b80925008669b5a53b6097e Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 10 Dec 2024 10:09:56 -0500 Subject: [PATCH 083/148] [CN-Test-Gen] Add input discard timeout (#747) --- backend/cn/bin/main.ml | 11 ++++ backend/cn/lib/testGeneration/specTests.ml | 5 ++ .../cn/lib/testGeneration/testGenConfig.ml | 4 ++ .../cn/lib/testGeneration/testGenConfig.mli | 3 + runtime/libcn/include/cn-testing/dsl.h | 18 +++--- runtime/libcn/include/cn-testing/size.h | 8 +++ runtime/libcn/include/cn-testing/test.h | 7 ++- runtime/libcn/src/cn-testing/size.c | 55 +++++++++++++++++++ runtime/libcn/src/cn-testing/test.c | 14 +++-- tests/run-cn-test-gen.sh | 2 +- 10 files changed, 109 insertions(+), 18 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index de5f2ea9f..8b1ae8aa2 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -458,6 +458,7 @@ let run_tests max_backtracks max_unfolds max_array_length + input_timeout null_in_every seed logging_level @@ -532,6 +533,7 @@ let run_tests max_backtracks; max_unfolds; max_array_length; + input_timeout; null_in_every; seed; logging_level; @@ -967,6 +969,14 @@ module Testing_flags = struct & info [ "max-array-length" ] ~doc) + let input_timeout = + let doc = "Timeout for discarding a generation attempt (ms)" in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.input_timeout + & info [ "input-timeout" ] ~doc) + + let null_in_every = let doc = "Set the likelihood of NULL being generated as 1 in every " in Arg.( @@ -1103,6 +1113,7 @@ let testing_cmd = $ Testing_flags.gen_backtrack_attempts $ Testing_flags.gen_max_unfolds $ Testing_flags.max_array_length + $ Testing_flags.input_timeout $ Testing_flags.null_in_every $ Testing_flags.seed $ Testing_flags.logging_level diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 4fa7c7381..c3affa803 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -433,6 +433,11 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = space string ([ "./tests.out" ] + @ (Config.has_input_timeout () + |> Option.map (fun input_timeout -> + [ "--input-timeout"; string_of_int input_timeout ]) + |> Option.to_list + |> List.flatten) @ (Config.has_null_in_every () |> Option.map (fun null_in_every -> [ "--null-in-every"; string_of_int null_in_every ]) diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index 08f9c9b5f..4519710e3 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -4,6 +4,7 @@ type t = max_backtracks : int; max_unfolds : int option; max_array_length : int; + input_timeout : int option; (* Run time *) null_in_every : int option; seed : string option; @@ -26,6 +27,7 @@ let default = max_backtracks = 25; max_unfolds = None; max_array_length = 50; + input_timeout = None; null_in_every = None; seed = None; logging_level = None; @@ -55,6 +57,8 @@ let get_max_unfolds () = !instance.max_unfolds let get_max_array_length () = !instance.max_array_length +let has_input_timeout () = !instance.input_timeout + let has_null_in_every () = !instance.null_in_every let has_seed () = !instance.seed diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 4ef4789ea..5c12eca30 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -5,6 +5,7 @@ type t = max_unfolds : int option; max_array_length : int; (* Run time *) + input_timeout : int option; null_in_every : int option; seed : string option; logging_level : int option; @@ -33,6 +34,8 @@ val get_max_unfolds : unit -> int option val get_max_array_length : unit -> int +val has_input_timeout : unit -> int option + val has_null_in_every : unit -> int option val has_seed : unit -> string option diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index bb458b599..86153b02c 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -7,19 +7,15 @@ #include "backtrack.h" -#define CN_GEN_INIT() \ - if (0) { \ - cn_label_bennet_backtrack: \ - cn_gen_decrement_depth(); \ - return NULL; \ - } \ - cn_gen_increment_depth(); \ - if (cn_gen_depth() == cn_gen_max_depth()) { \ - cn_gen_backtrack_depth_exceeded(); \ - goto cn_label_bennet_backtrack; \ - } +#define CN_GEN_INIT() CN_GEN_INIT_SIZED(cn_gen_get_max_size()) #define CN_GEN_INIT_SIZED(size) \ + if (cn_gen_get_input_timeout() != 0 \ + && cn_gen_get_milliseconds() - cn_gen_get_input_timer() \ + > cn_gen_get_input_timeout()) { \ + cn_gen_backtrack_assert_failure(); \ + goto cn_label_bennet_backtrack; \ + } \ if (0) { \ cn_label_bennet_backtrack: \ cn_gen_decrement_depth(); \ diff --git a/runtime/libcn/include/cn-testing/size.h b/runtime/libcn/include/cn-testing/size.h index 6375724c2..445e8b86e 100644 --- a/runtime/libcn/include/cn-testing/size.h +++ b/runtime/libcn/include/cn-testing/size.h @@ -18,3 +18,11 @@ uint16_t cn_gen_get_depth_failures_allowed(); void cn_gen_set_size_split_backtracks_allowed(uint16_t allowed); uint16_t cn_gen_get_size_split_backtracks_allowed(); + +void cn_gen_set_input_timeout(uint8_t seconds); +uint8_t cn_gen_get_input_timeout(void); + +void cn_gen_set_input_timer(uint64_t time); +uint64_t cn_gen_get_input_timer(void); + +uint64_t cn_gen_get_milliseconds(void); diff --git a/runtime/libcn/include/cn-testing/test.h b/runtime/libcn/include/cn-testing/test.h index 5f07897db..33c43bf73 100644 --- a/runtime/libcn/include/cn-testing/test.h +++ b/runtime/libcn/include/cn-testing/test.h @@ -41,16 +41,17 @@ void print_test_info(char* suite, char* name, int tests, int discards); enum cn_test_result cn_test_##Name (int printing) { \ cn_gen_rand_checkpoint checkpoint = cn_gen_rand_save(); \ int i = 0, d = 0; \ + set_cn_failure_cb(&cn_test_##Name##_fail); \ switch (setjmp(buf_##Name)) { \ case CN_FAILURE_ASSERT: \ case CN_FAILURE_CHECK_OWNERSHIP: \ case CN_FAILURE_OWNERSHIP_LEAK: \ return CN_TEST_FAIL; \ case CN_FAILURE_ALLOC: \ + cn_gen_rand_replace(checkpoint); \ d++; \ break; \ } \ - set_cn_failure_cb(&cn_test_##Name##_fail); \ for (; i < Samples; i++) { \ if (printing) { \ printf("\r"); \ @@ -59,12 +60,13 @@ void print_test_info(char* suite, char* name, int tests, int discards); if (d == 10 * Samples) { \ return CN_TEST_GEN_FAIL; \ } \ - cn_gen_rand_replace(checkpoint); \ size_t sz = cn_gen_uniform_cn_bits_u16(cn_gen_get_max_size())->val + 1; \ cn_gen_set_size(sz); \ CN_TEST_INIT(); \ + cn_gen_set_input_timer(cn_gen_get_milliseconds()); \ struct cn_gen_##Name##_record *res = cn_gen_##Name(); \ if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ + cn_gen_rand_replace(checkpoint); \ i--; \ d++; \ continue; \ @@ -72,6 +74,7 @@ void print_test_info(char* suite, char* name, int tests, int discards); assume_##Name(__VA_ARGS__); \ Init(res); \ Name(__VA_ARGS__); \ + cn_gen_rand_replace(checkpoint); \ } \ \ if (printing) { \ diff --git a/runtime/libcn/src/cn-testing/size.c b/runtime/libcn/src/cn-testing/size.c index 9945385ab..63662efab 100644 --- a/runtime/libcn/src/cn-testing/size.c +++ b/runtime/libcn/src/cn-testing/size.c @@ -62,3 +62,58 @@ void cn_gen_set_size_split_backtracks_allowed(uint16_t allowed) { uint16_t cn_gen_get_size_split_backtracks_allowed() { return size_split_backtracks_allowed; } + +static uint8_t timeout = 0; + +void cn_gen_set_input_timeout(uint8_t seconds) { + timeout = seconds; +} + +uint8_t cn_gen_get_input_timeout(void) { + return timeout; +} + +static uint64_t timer = 0; + +void cn_gen_set_input_timer(uint64_t time) { + timer = time; +} + +uint64_t cn_gen_get_input_timer(void) { + return timer; +} + +#if defined (__unix__) || (defined (__APPLE__) && defined (__MACH__)) +#include +#elif defined(_WIN32) || defined(_WIN64) +#include + +/// Taken from https://stackoverflow.com/questions/10905892/equivalent-of-gettimeofday-for-windows +int gettimeofday(struct timeval* tp, struct timezone* tzp) +{ + // Note: some broken versions only have 8 trailing zero's, the correct epoch has 9 trailing zero's + // This magic number is the number of 100 nanosecond intervals since January 1, 1601 (UTC) + // until 00:00:00 January 1, 1970 + static const uint64_t EPOCH = ((uint64_t)116444736000000000ULL); + + SYSTEMTIME system_time; + FILETIME file_time; + uint64_t time; + + GetSystemTime(&system_time); + SystemTimeToFileTime(&system_time, &file_time); + time = ((uint64_t)file_time.dwLowDateTime); + time += ((uint64_t)file_time.dwHighDateTime) << 32; + + tp->tv_sec = (long)((time - EPOCH) / 10000000L); + tp->tv_usec = (long)(system_time.wMilliseconds * 1000); + return 0; +} +#endif + +uint64_t cn_gen_get_milliseconds(void) { + struct timeval tv; + + gettimeofday(&tv, NULL); + return (((uint64_t)tv.tv_sec) * 1000) + (tv.tv_usec / 1000); +} diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index 8e2d5342a..e5223f7f0 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -1,4 +1,3 @@ -#include #include #include #include @@ -54,14 +53,15 @@ void print_test_info(char* suite, char* name, int tests, int discards) { } int cn_test_main(int argc, char* argv[]) { - int begin_time = time(NULL); + int begin_time = cn_gen_get_milliseconds(); set_cn_logging_level(CN_LOGGING_NONE); - cn_gen_srand(time(NULL)); + cn_gen_srand(cn_gen_get_milliseconds()); uint64_t seed = cn_gen_rand(); int interactive = 0; enum cn_logging_level logging_level = CN_LOGGING_ERROR; int timeout = 0; + int input_timeout = 0; int exit_fast = 0; for (int i = 0; i < argc; i++) { char* arg = argv[i]; @@ -77,6 +77,10 @@ int cn_test_main(int argc, char* argv[]) { logging_level = strtol(argv[i + 1], NULL, 10); i++; } + else if (strcmp("--input-timeout", arg) == 0) { + input_timeout = strtol(argv[i + 1], NULL, 10); + i++; + } else if (strcmp("--null-in-every", arg) == 0) { set_null_in_every(strtol(argv[i + 1], NULL, 10)); i++; @@ -138,6 +142,7 @@ int cn_test_main(int argc, char* argv[]) { struct cn_test_case* test_case = &test_cases[i]; print_test_info(test_case->suite, test_case->name, 0, 0); checkpoints[i] = cn_gen_rand_save(); + cn_gen_set_input_timeout(input_timeout); enum cn_test_result result = test_case->func(1); if (!(results[i] == CN_TEST_PASS && result == CN_TEST_GEN_FAIL)) { results[i] = result; @@ -151,6 +156,7 @@ int cn_test_main(int argc, char* argv[]) { printf("FAILED\n"); set_cn_logging_level(logging_level); cn_gen_rand_restore(checkpoints[i]); + cn_gen_set_input_timeout(0); test_case->func(0); set_cn_logging_level(CN_LOGGING_NONE); printf("\n\n"); @@ -168,7 +174,7 @@ int cn_test_main(int argc, char* argv[]) { } if (timeout != 0) { - timediff = time(NULL) - begin_time; + timediff = cn_gen_get_milliseconds() / 1000 - begin_time; } } if (timediff < timeout) { diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index a1f28258e..c0c6fd1b6 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -35,7 +35,7 @@ for CONFIG in ${CONFIGS[@]}; do echo "Running CI with CLI config \"$CONFIG\"" separator - CONFIG="$CONFIG --max-generator-size=10 --allowed-depth-failures=100" + CONFIG="$CONFIG --allowed-depth-failures=100 --input-timeout=1000" # Test each `*.c` file for TEST in $FILES; do From 31f419b6b6c5de0993f193b59c2e423e53fd4be1 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 13:36:20 +0000 Subject: [PATCH 084/148] CN VIP: Tidy up loc info for Alloc --- backend/cn/bin/main.ml | 2 +- backend/cn/lib/alloc.ml | 6 ++---- backend/cn/lib/alloc.mli | 4 +--- 3 files changed, 4 insertions(+), 8 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 8b1ae8aa2..cba024a8a 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -66,7 +66,7 @@ let frontend ~macros ~incl_dirs ~incl_files astprints ~filename ~magic_comment_c let cn_init_scope : Cn_desugaring.init_scope = { predicates = [ Alloc.Predicate.(str, sym, Some loc) ]; functions = List.map (fun (str, sym) -> (str, sym, None)) cn_builtin_fun_names; - idents = [ Alloc.History.(str, sym, Some loc) ] + idents = [ Alloc.History.(str, sym, None) ] } in let@ _, ail_prog_opt, prog0 = diff --git a/backend/cn/lib/alloc.ml b/backend/cn/lib/alloc.ml index 1edb5c035..2179d5bbf 100644 --- a/backend/cn/lib/alloc.ml +++ b/backend/cn/lib/alloc.ml @@ -3,8 +3,6 @@ module History = struct let sym = Sym.fresh_named str - let loc = Locations.other __MODULE__ - let base_id = Id.id "base" let base_bt = Memory.uintptr_bt @@ -22,11 +20,11 @@ module History = struct let bt = BaseTypes.Map (Alloc_id, value_bt) - let it = IndexTerms.sym_ (sym, bt, loc) + let it loc' = IndexTerms.sym_ (sym, bt, loc') let lookup_ptr ptr loc' = assert (BaseTypes.(equal (IndexTerms.bt ptr) (Loc ()))); - IndexTerms.(map_get_ it (allocId_ ptr loc') loc') + IndexTerms.(map_get_ (it loc') (allocId_ ptr loc') loc') let get_base_size ptr loc' = diff --git a/backend/cn/lib/alloc.mli b/backend/cn/lib/alloc.mli index b4704ad56..23c438002 100644 --- a/backend/cn/lib/alloc.mli +++ b/backend/cn/lib/alloc.mli @@ -3,8 +3,6 @@ module History : sig val sym : Sym.t - val loc : Locations.t - val base_id : Id.t val base_bt : BaseTypes.t @@ -19,7 +17,7 @@ module History : sig val bt : BaseTypes.t - val it : IndexTerms.t + val it : Cerb_location.t -> IndexTerms.t val lookup_ptr : IndexTerms.t -> Locations.t -> IndexTerms.t From 14255906464e7b006569b2545c6176e42a3b67ae Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 14:02:21 +0000 Subject: [PATCH 085/148] CN VIP: Use record for base and size in Alloc --- backend/cn/lib/alloc.ml | 12 +++++++++--- backend/cn/lib/alloc.mli | 7 ++++++- backend/cn/lib/check.ml | 14 +++++++------- backend/cn/lib/resources.ml | 13 +++++++------ 4 files changed, 29 insertions(+), 17 deletions(-) diff --git a/backend/cn/lib/alloc.ml b/backend/cn/lib/alloc.ml index 2179d5bbf..41ad3cb69 100644 --- a/backend/cn/lib/alloc.ml +++ b/backend/cn/lib/alloc.ml @@ -27,10 +27,16 @@ module History = struct IndexTerms.(map_get_ (it loc') (allocId_ ptr loc') loc') - let get_base_size ptr loc' = + type value = + { base : IndexTerms.t; + size : IndexTerms.t + } + + let split value loc' = IndexTerms. - ( recordMember_ ~member_bt:base_bt (ptr, base_id) loc', - recordMember_ ~member_bt:size_bt (ptr, size_id) loc' ) + { base = recordMember_ ~member_bt:base_bt (value, base_id) loc'; + size = recordMember_ ~member_bt:size_bt (value, size_id) loc' + } let sbt = BaseTypes.Surface.inj bt diff --git a/backend/cn/lib/alloc.mli b/backend/cn/lib/alloc.mli index 23c438002..924920061 100644 --- a/backend/cn/lib/alloc.mli +++ b/backend/cn/lib/alloc.mli @@ -21,7 +21,12 @@ module History : sig val lookup_ptr : IndexTerms.t -> Locations.t -> IndexTerms.t - val get_base_size : IndexTerms.t -> Cerb_location.t -> IndexTerms.t * IndexTerms.t + type value = + { base : IndexTerms.t; + size : IndexTerms.t + } + + val split : IndexTerms.t -> Cerb_location.t -> value val sbt : BaseTypes.Surface.t end diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index b90e66e08..12caffc3e 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -437,8 +437,8 @@ let check_has_alloc_id loc ptr ub_unspec = let check_alloc_bounds loc ~ptr ub_unspec = if !use_vip then ( let here = Locations.other __FUNCTION__ in - let base_size = Alloc.History.lookup_ptr ptr here in - let base, size = Alloc.History.get_base_size base_size here in + let module H = Alloc.History in + let H.{ base; size } = H.(split (lookup_ptr ptr here) here) in let addr = addr_ ptr here in let lower = le_ (base, addr) here in let upper = le_ (addr, add_ (base, size) here) here in @@ -476,7 +476,7 @@ let check_both_eq_alloc loc arg1 arg2 ub = let check_live_alloc_bounds reason loc arg ub term constr = let@ base_size = RI.Special.get_live_alloc reason loc arg in let here = Locations.other __FUNCTION__ in - let base, size = Alloc.History.get_base_size base_size here in + let Alloc.History.{ base; size } = Alloc.History.split base_size here in if !use_vip then ( let constr = constr ~base ~size in let@ provable = provable loc in @@ -2298,9 +2298,9 @@ let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> unit m = let ptr = sym_ (sym, bt, here) in let@ () = add_c here (LC.T (IT.hasAllocId_ ptr here)) in let@ () = - if !IT.use_vip then ( - let base_size = Alloc.History.lookup_ptr ptr here in - let base, size = Alloc.History.get_base_size base_size here in + if !IT.use_vip then + let module H = Alloc.History in + let H.{ base; size } = H.(split (lookup_ptr ptr here) here) in let addr = addr_ ptr here in let upper = Resources.upper_bound addr ct here in let bounds = @@ -2311,7 +2311,7 @@ let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> unit m = ] here in - add_c here (LC.T bounds)) + add_c here (LC.T bounds) else return () in diff --git a/backend/cn/lib/resources.ml b/backend/cn/lib/resources.ml index bfd47f2f1..72213bc7c 100644 --- a/backend/cn/lib/resources.ml +++ b/backend/cn/lib/resources.ml @@ -44,17 +44,18 @@ let derived_lc1 (resource, O oarg) = let addr = IT.addr_ pointer here in let upper = upper_bound addr ct here in let alloc_bounds = - if !IT.use_vip then ( - let lookup = Alloc.History.lookup_ptr pointer here in - let base, size = Alloc.History.get_base_size lookup here in - [ IT.(le_ (base, addr) here); IT.(le_ (upper, add_ (base, size) here) here) ]) + if !IT.use_vip then + let module H = Alloc.History in + let H.{ base; size } = H.(split (lookup_ptr pointer here) here) in + [ IT.(le_ (base, addr) here); IT.(le_ (upper, add_ (base, size) here) here) ] else [] in [ IT.hasAllocId_ pointer here; IT.(le_ (addr, upper) here) ] @ alloc_bounds | P { name; pointer; iargs = [] } when !IT.use_vip && equal_predicate_name name alloc -> - let lookup = Alloc.History.lookup_ptr pointer here in - let base, size = Alloc.History.get_base_size lookup here in + let module H = Alloc.History in + let lookup = H.lookup_ptr pointer here in + let H.{ base; size } = H.split lookup here in [ IT.(eq_ (lookup, oarg) here); IT.(le_ (base, add_ (base, size) here) here) ] | Q { name = Owned _; pointer; _ } -> [ IT.hasAllocId_ pointer here ] | P { name = PName _; pointer = _; iargs = _ } | Q { name = PName _; _ } -> [] From cc1bd050f772874134de3e166537454e2d59ae2f Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Tue, 10 Dec 2024 12:53:23 -0500 Subject: [PATCH 086/148] [CN-Test-Gen] Allow controlling progress output (#751) --- backend/cn/bin/main.ml | 14 +++++++++++ backend/cn/lib/testGeneration/specTests.ml | 4 ++++ .../cn/lib/testGeneration/testGenConfig.ml | 4 ++++ .../cn/lib/testGeneration/testGenConfig.mli | 3 +++ runtime/libcn/include/cn-testing/test.h | 24 +++++++++++++++---- runtime/libcn/src/cn-testing/test.c | 17 ++++++++++--- tests/run-cn-test-gen.sh | 12 +++++----- 7 files changed, 64 insertions(+), 14 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index cba024a8a..0f3be56bc 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -462,6 +462,7 @@ let run_tests null_in_every seed logging_level + progress_level interactive until_timeout exit_fast @@ -537,6 +538,7 @@ let run_tests null_in_every; seed; logging_level; + progress_level; interactive; until_timeout; exit_fast; @@ -998,6 +1000,17 @@ module Testing_flags = struct & info [ "logging-level" ] ~doc) + let progress_level = + let doc = + "Set the level of detail for progress updates (0 = Quiet, 1 = Per function, 2 = \ + Per test case)" + in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.progress_level + & info [ "progress-level" ] ~doc) + + let interactive = let doc = "Enable interactive features for testing, such as requesting more detailed logs" @@ -1117,6 +1130,7 @@ let testing_cmd = $ Testing_flags.null_in_every $ Testing_flags.seed $ Testing_flags.logging_level + $ Testing_flags.progress_level $ Testing_flags.interactive $ Testing_flags.until_timeout $ Testing_flags.exit_fast diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index c3affa803..cba09cfcf 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -451,6 +451,10 @@ let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = |> Option.map (fun level -> [ "--logging-level"; string_of_int level ]) |> Option.to_list |> List.flatten) + @ (Config.has_progress_level () + |> Option.map (fun level -> [ "--progress-level"; string_of_int level ]) + |> Option.to_list + |> List.flatten) @ (if Config.is_interactive () then [ "--interactive" ] else diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index 4519710e3..6c0746240 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -9,6 +9,7 @@ type t = null_in_every : int option; seed : string option; logging_level : int option; + progress_level : int option; interactive : bool; until_timeout : int option; exit_fast : bool; @@ -31,6 +32,7 @@ let default = null_in_every = None; seed = None; logging_level = None; + progress_level = None; interactive = false; until_timeout = None; exit_fast = false; @@ -65,6 +67,8 @@ let has_seed () = !instance.seed let has_logging_level () = !instance.logging_level +let has_progress_level () = !instance.progress_level + let is_interactive () = !instance.interactive let is_until_timeout () = !instance.until_timeout diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 5c12eca30..b5dd0a8d2 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -9,6 +9,7 @@ type t = null_in_every : int option; seed : string option; logging_level : int option; + progress_level : int option; interactive : bool; until_timeout : int option; exit_fast : bool; @@ -42,6 +43,8 @@ val has_seed : unit -> string option val has_logging_level : unit -> int option +val has_progress_level : unit -> int option + val is_interactive : unit -> bool val is_until_timeout : unit -> int option diff --git a/runtime/libcn/include/cn-testing/test.h b/runtime/libcn/include/cn-testing/test.h index 33c43bf73..a9b60b383 100644 --- a/runtime/libcn/include/cn-testing/test.h +++ b/runtime/libcn/include/cn-testing/test.h @@ -6,7 +6,13 @@ #include #include -typedef enum cn_test_result cn_test_case_fn(int); +enum cn_test_gen_progress { + CN_TEST_GEN_PROGRESS_NONE = 0, + CN_TEST_GEN_PROGRESS_FINAL = 1, + CN_TEST_GEN_PROGRESS_ALL = 2 +}; + +typedef enum cn_test_result cn_test_case_fn(enum cn_test_gen_progress); void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func); @@ -38,7 +44,7 @@ void print_test_info(char* suite, char* name, int tests, int discards); longjmp(buf_##Name, mode); \ } \ \ - enum cn_test_result cn_test_##Name (int printing) { \ + enum cn_test_result cn_test_##Name (enum cn_test_gen_progress progress_level) { \ cn_gen_rand_checkpoint checkpoint = cn_gen_rand_save(); \ int i = 0, d = 0; \ set_cn_failure_cb(&cn_test_##Name##_fail); \ @@ -46,6 +52,9 @@ void print_test_info(char* suite, char* name, int tests, int discards); case CN_FAILURE_ASSERT: \ case CN_FAILURE_CHECK_OWNERSHIP: \ case CN_FAILURE_OWNERSHIP_LEAK: \ + if (progress_level == CN_TEST_GEN_PROGRESS_FINAL) { \ + print_test_info(#Suite, #Name, i, d); \ + } \ return CN_TEST_FAIL; \ case CN_FAILURE_ALLOC: \ cn_gen_rand_replace(checkpoint); \ @@ -53,11 +62,14 @@ void print_test_info(char* suite, char* name, int tests, int discards); break; \ } \ for (; i < Samples; i++) { \ - if (printing) { \ + if (progress_level == CN_TEST_GEN_PROGRESS_ALL) { \ printf("\r"); \ print_test_info(#Suite, #Name, i, d); \ } \ if (d == 10 * Samples) { \ + if (progress_level == CN_TEST_GEN_PROGRESS_FINAL) { \ + print_test_info(#Suite, #Name, i, d); \ + } \ return CN_TEST_GEN_FAIL; \ } \ size_t sz = cn_gen_uniform_cn_bits_u16(cn_gen_get_max_size())->val + 1; \ @@ -77,8 +89,10 @@ void print_test_info(char* suite, char* name, int tests, int discards); cn_gen_rand_replace(checkpoint); \ } \ \ - if (printing) { \ - printf("\r"); \ + if (progress_level != CN_TEST_GEN_PROGRESS_NONE) { \ + if (progress_level == CN_TEST_GEN_PROGRESS_ALL) { \ + printf("\r"); \ + } \ print_test_info(#Suite, #Name, i, d); \ } \ return CN_TEST_PASS; \ diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index e5223f7f0..a5b3b95fa 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -57,6 +57,7 @@ int cn_test_main(int argc, char* argv[]) { set_cn_logging_level(CN_LOGGING_NONE); cn_gen_srand(cn_gen_get_milliseconds()); + enum cn_test_gen_progress progress_level = CN_TEST_GEN_PROGRESS_ALL; uint64_t seed = cn_gen_rand(); int interactive = 0; enum cn_logging_level logging_level = CN_LOGGING_ERROR; @@ -77,6 +78,10 @@ int cn_test_main(int argc, char* argv[]) { logging_level = strtol(argv[i + 1], NULL, 10); i++; } + else if (strcmp("--progress-level", arg) == 0) { + progress_level = strtol(argv[i + 1], NULL, 10); + i++; + } else if (strcmp("--input-timeout", arg) == 0) { input_timeout = strtol(argv[i + 1], NULL, 10); i++; @@ -140,13 +145,19 @@ int cn_test_main(int argc, char* argv[]) { } struct cn_test_case* test_case = &test_cases[i]; - print_test_info(test_case->suite, test_case->name, 0, 0); + if (progress_level == CN_TEST_GEN_PROGRESS_ALL) { + print_test_info(test_case->suite, test_case->name, 0, 0); + } checkpoints[i] = cn_gen_rand_save(); cn_gen_set_input_timeout(input_timeout); - enum cn_test_result result = test_case->func(1); + enum cn_test_result result = test_case->func(progress_level); if (!(results[i] == CN_TEST_PASS && result == CN_TEST_GEN_FAIL)) { results[i] = result; } + if (progress_level == CN_TEST_GEN_PROGRESS_NONE) { + continue; + } + printf("\n"); switch (result) { case CN_TEST_PASS: @@ -157,7 +168,7 @@ int cn_test_main(int argc, char* argv[]) { set_cn_logging_level(logging_level); cn_gen_rand_restore(checkpoints[i]); cn_gen_set_input_timeout(0); - test_case->func(0); + test_case->func(CN_TEST_GEN_PROGRESS_NONE); set_cn_logging_level(CN_LOGGING_NONE); printf("\n\n"); break; diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index c0c6fd1b6..fdc56cb05 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -30,12 +30,12 @@ function separator() { CONFIGS=("--coverage" "--sized-null" "--random-size-splits" "--random-size-splits --allowed-size-split-backtracks=10") # For each configuration -for CONFIG in ${CONFIGS[@]}; do +for CONFIG in "${CONFIGS[@]}"; do separator echo "Running CI with CLI config \"$CONFIG\"" separator - CONFIG="$CONFIG --allowed-depth-failures=100 --input-timeout=1000" + FULL_CONFIG="$CONFIG --allowed-depth-failures=100 --input-timeout=1000 --progress-level=1" # Test each `*.c` file for TEST in $FILES; do @@ -43,13 +43,13 @@ for CONFIG in ${CONFIGS[@]}; do # Run passing tests if [[ $TEST == *.pass.c ]]; then - $CN test "$TEST" --output-dir="test" $CONFIG + $CN test "$TEST" --output-dir="test" $FULL_CONFIG RET=$? if [[ "$RET" != 0 ]]; then echo echo "$TEST -- Tests failed unexpectedly" NUM_FAILED=$(($NUM_FAILED + 1)) - FAILED="$FAILED $TEST" + FAILED="$FAILED $TEST($CONFIG)" eval "$CLEANUP" continue else @@ -60,13 +60,13 @@ for CONFIG in ${CONFIGS[@]}; do # Run failing tests if [[ $TEST == *.fail.c ]]; then - $CN test "$TEST" --output-dir="test" $CONFIG + $CN test "$TEST" --output-dir="test" $FULL_CONFIG RET=$? if [[ "$RET" = 0 ]]; then echo echo "$TEST -- Tests passed unexpectedly" NUM_FAILED=$(($NUM_FAILED + 1)) - FAILED="$FAILED $TEST" + FAILED="$FAILED $TEST($CONFIG)" eval "$CLEANUP" continue else From ffff23ff642b280a33030c20db731c9e33dbaf51 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 14:57:36 +0000 Subject: [PATCH 087/148] Add mli for ResourceTypes --- backend/cn/lib/resourceTypes.ml | 2 + backend/cn/lib/resourceTypes.mli | 79 ++++++++++++++++++++++++++++++++ 2 files changed, 81 insertions(+) create mode 100644 backend/cn/lib/resourceTypes.mli diff --git a/backend/cn/lib/resourceTypes.ml b/backend/cn/lib/resourceTypes.ml index 3efe60b13..9b11b9a15 100644 --- a/backend/cn/lib/resourceTypes.ml +++ b/backend/cn/lib/resourceTypes.ml @@ -7,6 +7,8 @@ open IT module LC = LogicalConstraints module LCSet = Set.Make (LC) +[@@@ocaml.warning "-32"] + type init = | Init | Uninit diff --git a/backend/cn/lib/resourceTypes.mli b/backend/cn/lib/resourceTypes.mli new file mode 100644 index 000000000..e72cb6893 --- /dev/null +++ b/backend/cn/lib/resourceTypes.mli @@ -0,0 +1,79 @@ +module LCSet : + Set.S with type elt = LogicalConstraints.t and type t = Set.Make(LogicalConstraints).t + +type init = + | Init + | Uninit + +type predicate_name = + | Owned of Sctypes.t * init + | PName of Sym.t +[@@deriving eq] + +val alloc : predicate_name + +val pp_predicate_name : predicate_name -> Pp.document + +type predicate_type = + { name : predicate_name; + pointer : IndexTerms.t; + iargs : IndexTerms.t list + } + +val make_alloc : IndexTerms.t -> predicate_type + +type qpredicate_type = + { name : predicate_name; + pointer : IndexTerms.t; + q : Sym.t * BaseTypes.t; + q_loc : Locations.t; + step : IndexTerms.t; + permission : IndexTerms.t; + iargs : IndexTerms.t list + } + +val subsumed : predicate_name -> predicate_name -> bool + +type resource_type = + | P of predicate_type + | Q of qpredicate_type + +type t = resource_type + +val predicate_name : resource_type -> predicate_name + +val pp_aux : resource_type -> 'a Terms.annot option -> Pp.document + +val pp : resource_type -> Pp.document + +val equal : resource_type -> resource_type -> bool + +val json : resource_type -> Yojson.Safe.t + +val alpha_rename_qpredicate_type_ : Sym.t -> qpredicate_type -> qpredicate_type + +val alpha_rename_qpredicate_type : qpredicate_type -> qpredicate_type + +val subst_predicate_type + : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> + predicate_type -> + predicate_type + +val subst + : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> + resource_type -> + resource_type + +val free_vars_bts : resource_type -> BaseTypes.t IndexTerms.SymMap.t + +val free_vars : resource_type -> IndexTerms.SymSet.t + +val same_predicate_name : resource_type -> resource_type -> bool + +val alpha_equivalent : resource_type -> resource_type -> bool + +val steps_constant : resource_type -> bool + +val dtree_of_predicate_type : predicate_type -> Cerb_frontend.Pp_ast.doc_tree + +val dtree : resource_type -> Cerb_frontend.Pp_ast.doc_tree From 894ebed993f95e839b94c88cf9f4b9943ec9ff0b Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 14:59:06 +0000 Subject: [PATCH 088/148] Remove unused functions --- backend/cn/lib/resourceTypes.ml | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/backend/cn/lib/resourceTypes.ml b/backend/cn/lib/resourceTypes.ml index 9b11b9a15..ecf321597 100644 --- a/backend/cn/lib/resourceTypes.ml +++ b/backend/cn/lib/resourceTypes.ml @@ -7,8 +7,6 @@ open IT module LC = LogicalConstraints module LCSet = Set.Make (LC) -[@@@ocaml.warning "-32"] - type init = | Init | Uninit @@ -90,10 +88,6 @@ let pp_qpredicate_type_aux (p : qpredicate_type) oargs = ^^ pp_maybe_oargs oargs -let pp_predicate_type p = pp_predicate_type_aux p None - -let pp_qpredicate_type p = pp_qpredicate_type_aux p None - let pp_aux r o = match r with P p -> pp_predicate_type_aux p o | Q qp -> pp_qpredicate_type_aux qp o @@ -102,8 +96,6 @@ let pp r = pp_aux r None let equal = equal_resource_type -let compare = compare_resource_type - let json re : Yojson.Safe.t = `String (Pp.plain (pp re)) let alpha_rename_qpredicate_type_ (q' : Sym.t) (qp : qpredicate_type) = @@ -187,8 +179,6 @@ let alpha_equivalent r1 r2 = let steps_constant = function Q qp -> Option.is_some (IT.is_const qp.step) | _ -> true -let pointer = function P pred -> pred.pointer | Q pred -> pred.pointer - open Cerb_frontend.Pp_ast open Pp From a6d86658cb2f0d46a3e2eeec14cd7309d39b4fc0 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 15:04:27 +0000 Subject: [PATCH 089/148] Tidy modules in ResourceTypes --- backend/cn/lib/resourceTypes.ml | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/backend/cn/lib/resourceTypes.ml b/backend/cn/lib/resourceTypes.ml index ecf321597..3291b6f5c 100644 --- a/backend/cn/lib/resourceTypes.ml +++ b/backend/cn/lib/resourceTypes.ml @@ -1,11 +1,8 @@ -open Pp -module CF = Cerb_frontend -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) +open Pp.Infix module IT = IndexTerms -open IT -module LC = LogicalConstraints -module LCSet = Set.Make (LC) +module SymSet = IT.SymSet +module SymMap = IT.SymMap +module LCSet = Set.Make (LogicalConstraints) type init = | Init @@ -22,8 +19,8 @@ let alloc = PName Alloc.Predicate.sym let pp_init = function Init -> !^"Init" | Uninit -> !^"Uninit" let pp_predicate_name = function - | Owned (ct, Init) -> !^"Owned" ^^ angles (Sctypes.pp ct) - | Owned (ct, Uninit) -> !^"Block" ^^ angles (Sctypes.pp ct) + | Owned (ct, Init) -> !^"Owned" ^^ Pp.angles (Sctypes.pp ct) + | Owned (ct, Uninit) -> !^"Block" ^^ Pp.angles (Sctypes.pp ct) | PName pn -> Sym.pp pn @@ -39,7 +36,7 @@ let make_alloc pointer = { name = alloc; pointer; iargs = [] } type qpredicate_type = { name : predicate_name; pointer : IT.t; (* I *) - q : Sym.t * BT.t; + q : Sym.t * BaseTypes.t; q_loc : Locations.t; [@equal fun _ _ -> true] [@compare fun _ _ -> 0] step : IT.t; permission : IT.t; (* I, function of q *) @@ -65,15 +62,16 @@ type t = resource_type let predicate_name = function P p -> p.name | Q p -> p.name -let pp_maybe_oargs = function None -> Pp.empty | Some oargs -> parens (IT.pp oargs) +let pp_maybe_oargs = function None -> Pp.empty | Some oargs -> Pp.parens (IT.pp oargs) let pp_predicate_type_aux (p : predicate_type) oargs = let args = List.map IT.pp (p.pointer :: p.iargs) in - c_app (pp_predicate_name p.name) args ^^ pp_maybe_oargs oargs + Pp.c_app (pp_predicate_name p.name) args ^^ pp_maybe_oargs oargs let pp_qpredicate_type_aux (p : qpredicate_type) oargs = - (* XXX: this is `p + i * step` but that's "wrong" in a couple of ways: + let open Pp in + (* ISD: this is `p + i * step` but that's "wrong" in a couple of ways: - we are not using the correct precedences for `p` and `step` - in C pointer arithmetic takes account of the types, but here we seem to be doing it at the byte level. Would `step` ever @@ -83,7 +81,7 @@ let pp_qpredicate_type_aux (p : qpredicate_type) oargs = let pointer = IT.pp p.pointer ^^^ plus ^^^ Sym.pp (fst p.q) ^^^ star ^^^ IT.pp p.step in let args = pointer :: List.map IT.pp p.iargs in !^"each" - ^^ parens (BT.pp (snd p.q) ^^^ Sym.pp (fst p.q) ^^ semi ^^^ IT.pp p.permission) + ^^ parens (BaseTypes.pp (snd p.q) ^^^ Sym.pp (fst p.q) ^^ semi ^^^ IT.pp p.permission) ^/^ braces (c_app (pp_predicate_name p.name) args) ^^ pp_maybe_oargs oargs @@ -99,7 +97,7 @@ let equal = equal_resource_type let json re : Yojson.Safe.t = `String (Pp.plain (pp re)) let alpha_rename_qpredicate_type_ (q' : Sym.t) (qp : qpredicate_type) = - let subst = make_rename ~from:(fst qp.q) ~to_:q' in + let subst = IT.make_rename ~from:(fst qp.q) ~to_:q' in { name = qp.name; pointer = qp.pointer; q = (q', snd qp.q); @@ -148,7 +146,7 @@ let free_vars_bts = function | Q p -> SymMap.union (fun _ bt1 bt2 -> - assert (BT.equal bt1 bt2); + assert (BaseTypes.equal bt1 bt2); Some bt1) (IT.free_vars_bts_list [ p.pointer; p.step ]) (SymMap.remove (fst p.q) (IT.free_vars_bts_list (p.permission :: p.iargs))) @@ -199,7 +197,7 @@ let dtree_of_predicate_type (pred : predicate_type) = let dtree_of_qpredicate_type (pred : qpredicate_type) = Dnode ( pp_ctor "qpred", - Dleaf (Pp.parens (Pp.typ (Sym.pp (fst pred.q)) (BT.pp (snd pred.q)))) + Dleaf (Pp.parens (Pp.typ (Sym.pp (fst pred.q)) (BaseTypes.pp (snd pred.q)))) :: IT.dtree pred.step :: IT.dtree pred.permission :: dtree_of_predicate_name pred.name From 67064fc628160efb931536cf7aa29d2539274a57 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 15:27:57 +0000 Subject: [PATCH 090/148] Unify all symbol sets and maps --- backend/cn/lib/argumentTypes.ml | 5 +- backend/cn/lib/cLogicalFuns.ml | 22 +- backend/cn/lib/check.ml | 32 +- backend/cn/lib/cn_internal_to_ail.ml | 2 +- backend/cn/lib/cnprog.ml | 2 +- backend/cn/lib/compile.ml | 152 +++++---- backend/cn/lib/context.ml | 39 ++- backend/cn/lib/core_to_mucore.ml | 16 +- backend/cn/lib/explain.ml | 12 +- backend/cn/lib/false.ml | 3 +- backend/cn/lib/false.mli | 4 +- backend/cn/lib/global.ml | 52 ++- backend/cn/lib/indexTerms.ml | 68 ++-- backend/cn/lib/interval.ml | 2 +- backend/cn/lib/lemmata.ml | 54 ++-- backend/cn/lib/logicalArgumentTypes.ml | 24 +- backend/cn/lib/logicalConstraints.ml | 6 +- backend/cn/lib/logicalFunctions.ml | 16 +- backend/cn/lib/logicalReturnTypes.ml | 21 +- backend/cn/lib/logicalSorts.ml | 1 - backend/cn/lib/memory.ml | 3 +- backend/cn/lib/mucore.ml | 6 +- backend/cn/lib/mucore.mli | 2 +- backend/cn/lib/pack.ml | 6 +- backend/cn/lib/resourceTypes.ml | 14 +- backend/cn/lib/resourceTypes.mli | 4 +- backend/cn/lib/resources.ml | 6 +- backend/cn/lib/returnTypes.ml | 7 +- backend/cn/lib/simplify.ml | 8 +- backend/cn/lib/solver.ml | 40 ++- backend/cn/lib/subst.ml | 13 +- backend/cn/lib/sym.ml | 11 +- backend/cn/lib/testGeneration/genAnalysis.ml | 64 ++-- backend/cn/lib/testGeneration/genCodeGen.ml | 17 +- backend/cn/lib/testGeneration/genCompile.ml | 56 ++-- .../cn/lib/testGeneration/genDistribute.ml | 2 - backend/cn/lib/testGeneration/genNormalize.ml | 1 - backend/cn/lib/testGeneration/genOptimize.ml | 304 +++++++++--------- backend/cn/lib/testGeneration/genRuntime.ml | 112 +++---- backend/cn/lib/testGeneration/genRuntime.mli | 12 +- backend/cn/lib/testGeneration/genTerms.ml | 28 +- backend/cn/lib/testGeneration/specTests.ml | 13 +- backend/cn/lib/typing.ml | 31 +- backend/cn/lib/wellTyped.ml | 18 +- 44 files changed, 638 insertions(+), 673 deletions(-) diff --git a/backend/cn/lib/argumentTypes.ml b/backend/cn/lib/argumentTypes.ml index dc58f10d1..3b56deb29 100644 --- a/backend/cn/lib/argumentTypes.ml +++ b/backend/cn/lib/argumentTypes.ml @@ -4,7 +4,6 @@ module IT = IndexTerms module LS = LogicalSorts module RET = ResourceTypes module LC = LogicalConstraints -module SymSet = Set.Make (Sym) module LAT = LogicalArgumentTypes type 'i t = @@ -29,7 +28,7 @@ and alpha_rename i_subst s t = and suitably_alpha_rename i_subst syms s t = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename i_subst s t else (s, t) @@ -82,7 +81,7 @@ let alpha_unique ss = match at with | Computational ((name, bt), info, t) -> let name, t = rename_if ss name t in - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in Computational ((name, bt), info, t) | L t -> L (LAT.alpha_unique ss t) in diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index 980af1821..823f3ca7d 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -3,8 +3,6 @@ open Typing open Effectful.Make (Typing) -module SymMap = Map.Make (Sym) -module SymSet = Set.Make (Sym) module StringMap = Map.Make (String) module IntMap = Map.Make (Int) module CF = Cerb_frontend @@ -47,7 +45,7 @@ type state = type context = { label_defs : (Sym.t, unit Mu.label_def) Pmap.map; (* map from c functions to logical functions which we are building *) - c_fun_pred_map : (Locations.t * Sym.t) SymMap.t; + c_fun_pred_map : (Locations.t * Sym.t) Sym.Map.t; call_funinfo : (Sym.t, Sctypes.c_concrete_sig) Pmap.map } @@ -131,7 +129,7 @@ let rec is_const_num = function let rec add_pattern p v var_map = let (Mu.Pattern (loc, _, _, pattern)) = p in match pattern with - | CaseBase (Some s, _) -> return (SymMap.add s v var_map) + | CaseBase (Some s, _) -> return (Sym.Map.add s v var_map) | CaseBase (None, _) -> return var_map | CaseCtor (Ctuple, ps) -> let@ vs = @@ -245,7 +243,7 @@ let rec symb_exec_pexpr ctxt var_map pexpr = in match pe with | PEsym sym -> - (match SymMap.find_opt sym var_map with + (match Sym.Map.find_opt sym var_map with | Some r -> return r | _ -> fail_n { loc; msg = Unknown_variable sym }) | PEval v -> @@ -541,8 +539,8 @@ let rec symb_exec_expr ctxt state_vars expr = | None -> fail_fun_it "not a constant function address" | Some (nm, _) -> return nm in - if SymMap.mem nm ctxt.c_fun_pred_map then ( - let loc, l_sym = SymMap.find nm ctxt.c_fun_pred_map in + if Sym.Map.mem nm ctxt.c_fun_pred_map then ( + let loc, l_sym = Sym.Map.find nm ctxt.c_fun_pred_map in let@ def = get_logical_function_def loc l_sym in rcval (IT.apply_ l_sym args_its def.LogicalFunctions.return_bt loc) state) else ( @@ -578,7 +576,7 @@ let rec filter_syms ss p = let (Mu.Pattern (a, b, c, pat)) = p in let mk pat = Mu.Pattern (a, b, c, pat) in match pat with - | CaseBase (Some s, bt) -> if SymSet.mem s ss then p else mk (CaseBase (None, bt)) + | CaseBase (Some s, bt) -> if Sym.Set.mem s ss then p else mk (CaseBase (None, bt)) | CaseBase (None, _) -> p | CaseCtor (Ctuple, ps) -> let ps = List.map (filter_syms ss) ps in @@ -645,7 +643,7 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ match (args_and_body, def_args) with | Mu.Computational ((s, bt), _, args_and_body), v :: def_args -> if BT.equal bt (IT.bt v) then - mk_var_map (SymMap.add s v acc) args_and_body def_args + mk_var_map (Sym.Map.add s v acc) args_and_body def_args else fail_n { loc; @@ -676,7 +674,7 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ (fun () -> in_computational_ctxt args_and_body m) | L _ -> m in - let@ arg_map, (body, labels, rt) = mk_var_map SymMap.empty args_and_body def_args in + let@ arg_map, (body, labels, rt) = mk_var_map Sym.Map.empty args_and_body def_args in let@ () = match rt with | ReturnTypes.Computational ((_, bt), _, _) -> @@ -729,8 +727,8 @@ let upd_def (loc, sym, def_tm) = let add_logical_funs_from_c call_funinfo funs_to_convert funs = let c_fun_pred_map = List.fold_left - (fun m Mu.{ c_fun_sym; loc; l_fun_sym } -> SymMap.add c_fun_sym (loc, l_fun_sym) m) - SymMap.empty + (fun m Mu.{ c_fun_sym; loc; l_fun_sym } -> Sym.Map.add c_fun_sym (loc, l_fun_sym) m) + Sym.Map.empty funs_to_convert in let global_context = diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 12caffc3e..9e86387c5 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -6,8 +6,6 @@ module RT = ReturnTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes module IdSet = Set.Make (Id) -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module Loc = Locations module RI = ResourceInference open IT @@ -339,7 +337,7 @@ let check_single_ct loc expr = let is_fun_addr global t = match IT.is_sym t with | Some (s, _) -> - if SymMap.mem s global.Global.fun_decls then + if Sym.Map.mem s global.Global.fun_decls then Some s else None @@ -353,7 +351,7 @@ let known_function_pointer loc p = match already_known with | Some _ -> (* no need to find more eqs *) return () | None -> - let global_funs = SymMap.bindings global.Global.fun_decls in + let global_funs = Sym.Map.bindings global.Global.fun_decls in let fun_addrs = List.map (fun (sym, (loc, _, _)) -> IT.sym_ (sym, BT.(Loc ()), loc)) global_funs in @@ -1192,7 +1190,7 @@ let _check_used_distinct loc used = ListM.iterM check_rd (List.concat (List.map fst used)) -(*type labels = (AT.lt * label_kind) SymMap.t*) +(*type labels = (AT.lt * label_kind) Sym.Map.t*) let load loc pointer ct = let@ value = @@ -2064,7 +2062,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Erun (label_sym, pes) -> let@ () = ensure_base_type loc ~expect Unit in let@ lt, lkind = - match SymMap.find_opt label_sym labels with + match Sym.Map.find_opt label_sym labels with | None -> fail (fun _ -> { loc; msg = Generic (!^"undefined code label" ^/^ Sym.pp label_sym) }) @@ -2175,7 +2173,7 @@ let check_procedure bind_arguments loc label_args_and_body in let@ () = add_rs loc label_resources in - let _, label_kind, loc = SymMap.find lsym label_context in + let _, label_kind, loc = Sym.Map.find lsym label_context in let@ () = modify_where Where.(set_section (Label { loc; label = label_kind })) in @@ -2384,27 +2382,27 @@ let c_function_name ((fsym, (_loc, _args_and_body)) : c_function) : string = (** Filter functions according to [skip_and_only]: first according to "only", then according to "skip" *) -let select_functions (fsyms : SymSet.t) : SymSet.t = +let select_functions (fsyms : Sym.Set.t) : Sym.Set.t = let matches_str s fsym = String.equal s (Sym.pp_string fsym) in let str_fsyms s = - let ss = SymSet.filter (matches_str s) fsyms in - if SymSet.is_empty ss then ( + let ss = Sym.Set.filter (matches_str s) fsyms in + if Sym.Set.is_empty ss then ( Pp.warn_noloc (!^"function" ^^^ !^s ^^^ !^"not found"); - SymSet.empty) + Sym.Set.empty) else ss in let strs_fsyms ss = - ss |> List.map str_fsyms |> List.fold_left SymSet.union SymSet.empty + ss |> List.map str_fsyms |> List.fold_left Sym.Set.union Sym.Set.empty in let skip = strs_fsyms (fst !skip_and_only) in let only = strs_fsyms (snd !skip_and_only) in let only_funs = match snd !skip_and_only with | [] -> fsyms - | _ss -> SymSet.filter (fun fsym -> SymSet.mem fsym only) fsyms + | _ss -> Sym.Set.filter (fun fsym -> Sym.Set.mem fsym only) fsyms in - SymSet.filter (fun fsym -> not (SymSet.mem fsym skip)) only_funs + Sym.Set.filter (fun fsym -> not (Sym.Set.mem fsym skip)) only_funs (** Check a single C function. Failure of the check is encoded monadically. *) @@ -2467,9 +2465,9 @@ let check_c_functions_all (funs : c_function list) : (string * TypeErrors.t) lis with the name of the function in which they occurred. When [fail_fast] is set, the first error encountered will halt checking. *) let check_c_functions (funs : c_function list) : (string * TypeErrors.t) list m = - let selected_fsyms = select_functions (SymSet.of_list (List.map fst funs)) in + let selected_fsyms = select_functions (Sym.Set.of_list (List.map fst funs)) in let selected_funs = - List.filter (fun (fsym, _) -> SymSet.mem fsym selected_fsyms) funs + List.filter (fun (fsym, _) -> Sym.Set.mem fsym selected_fsyms) funs in match !fail_fast with | true -> @@ -2647,7 +2645,7 @@ let check_decls_lemmata_fun_specs (file : unit Mu.file) = let@ () = record_globals file.globs in let@ () = register_fun_syms file in let@ () = - ListM.iterM (add_stdlib_spec file.call_funinfo) (SymSet.elements file.stdlib_syms) + ListM.iterM (add_stdlib_spec file.call_funinfo) (Sym.Set.elements file.stdlib_syms) in Pp.debug 3 (lazy (Pp.headline "added top-level types and constants.")); let@ () = record_and_check_logical_functions file.logical_predicates in diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 712948f15..64eb7dcdd 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -3339,7 +3339,7 @@ let rec cn_to_ail_lat_internal_2 else (loc, s) :: remove_duplicates (loc :: locs) ss in - (* let substitution : IT.t Subst.t = {replace = [(Sym.fresh_pretty "return", IT.(IT (Sym (Sym.fresh_pretty "__cn_ret"), BT.Unit)))]; relevant = SymSet.empty} in *) + (* let substitution : IT.t Subst.t = {replace = [(Sym.fresh_pretty "return", IT.(IT (Sym (Sym.fresh_pretty "__cn_ret"), BT.Unit)))]; relevant = Sym.Set.empty} in *) (* let post_with_ret = RT.subst substitution post in *) let return_cn_binding, return_cn_decl = match rm_ctype c_return_type with diff --git a/backend/cn/lib/cnprog.ml b/backend/cn/lib/cnprog.ml index fbf5e6c11..2e36eca28 100644 --- a/backend/cn/lib/cnprog.ml +++ b/backend/cn/lib/cnprog.ml @@ -73,7 +73,7 @@ and alpha_rename from prog = and suitably_alpha_rename syms s prog = - if IT.SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename s prog else (s, prog) diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 648d9613d..602bb9a0a 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -12,8 +12,6 @@ module RT = ReturnTypes open Pp open CF.Cn open TypeErrors -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module STermMap = Map.Make (IndexTerms.Surface) module StringMap = Map.Make (String) module StringSet = Set.Make (String) @@ -29,12 +27,12 @@ type predicate_sig = } type env = - { computationals : (SBT.t * Sym.t option) SymMap.t; - logicals : SBT.t SymMap.t; - predicates : predicate_sig SymMap.t; - functions : function_sig SymMap.t; - datatypes : BaseTypes.dt_info SymMap.t; - datatype_constrs : BaseTypes.constr_info SymMap.t; + { computationals : (SBT.t * Sym.t option) Sym.Map.t; + logicals : SBT.t Sym.Map.t; + predicates : predicate_sig Sym.Map.t; + functions : function_sig Sym.Map.t; + datatypes : BaseTypes.dt_info Sym.Map.t; + datatype_constrs : BaseTypes.constr_info Sym.Map.t; tagDefs : (Cerb_frontend.Symbol.sym, Mu.tag_definition) Pmap.map; fetch_enum_expr : Locations.t -> Sym.t -> unit CF.AilSyntax.expression Resultat.t; fetch_typedef : Locations.t -> Sym.t -> CF.Ctype.ctype Resultat.t @@ -42,12 +40,12 @@ type env = let init_env tagDefs fetch_enum_expr fetch_typedef = let alloc_sig = { pred_iargs = []; pred_output = ResourcePredicates.alloc.oarg_bt } in - { computationals = SymMap.empty; - logicals = SymMap.(empty |> add Alloc.History.sym Alloc.History.sbt); - predicates = SymMap.(empty |> add Alloc.Predicate.sym alloc_sig); - functions = SymMap.empty; - datatypes = SymMap.empty; - datatype_constrs = SymMap.empty; + { computationals = Sym.Map.empty; + logicals = Sym.Map.(empty |> add Alloc.History.sym Alloc.History.sbt); + predicates = Sym.Map.(empty |> add Alloc.Predicate.sym alloc_sig); + functions = Sym.Map.empty; + datatypes = Sym.Map.empty; + datatype_constrs = Sym.Map.empty; tagDefs; fetch_enum_expr; fetch_typedef @@ -64,32 +62,32 @@ let symtable = SymTable.create 10000 let add_computational sym bTy env = SymTable.add symtable sym bTy; - { env with computationals = SymMap.add sym (bTy, None) env.computationals } + { env with computationals = Sym.Map.add sym (bTy, None) env.computationals } let add_renamed_computational sym sym2 bTy env = SymTable.add symtable sym bTy; - { env with computationals = SymMap.add sym (bTy, Some sym2) env.computationals } + { env with computationals = Sym.Map.add sym (bTy, Some sym2) env.computationals } let add_logical sym bTy env = SymTable.add symtable sym bTy; - { env with logicals = SymMap.add sym bTy env.logicals } + { env with logicals = Sym.Map.add sym bTy env.logicals } let add_predicate sym pred_sig env = - { env with predicates = SymMap.add sym pred_sig env.predicates } + { env with predicates = Sym.Map.add sym pred_sig env.predicates } let lookup_computational_or_logical sym env = - match SymMap.find_opt sym env.logicals with + match Sym.Map.find_opt sym env.logicals with | Some bt -> Some (bt, None) - | None -> SymMap.find_opt sym env.computationals + | None -> Sym.Map.find_opt sym env.computationals -let lookup_predicate sym env = SymMap.find_opt sym env.predicates +let lookup_predicate sym env = Sym.Map.find_opt sym env.predicates -let lookup_function sym env = SymMap.find_opt sym env.functions +let lookup_function sym env = Sym.Map.find_opt sym env.functions let lookup_struct_opt sym env = match Pmap.lookup sym env.tagDefs with @@ -98,17 +96,17 @@ let lookup_struct_opt sym env = let add_datatype sym info env = - let datatypes = SymMap.add sym info env.datatypes in + let datatypes = Sym.Map.add sym info env.datatypes in { env with datatypes } let add_datatype_constr sym info env = - let datatype_constrs = SymMap.add sym info env.datatype_constrs in + let datatype_constrs = Sym.Map.add sym info env.datatype_constrs in { env with datatype_constrs } let get_datatype_maps env = - (SymMap.bindings env.datatypes, SymMap.bindings env.datatype_constrs) + (Sym.Map.bindings env.datatypes, Sym.Map.bindings env.datatype_constrs) type cn_predicate = (CF.Symbol.sym, CF.Ctype.ctype) CF.Cn.cn_predicate @@ -158,22 +156,22 @@ type cn_datatype = CF.Symbol.sym CF.Cn.cn_datatype (* | CNExpr_default bt -> !^"default" *) let rec symset_bigunion = function - | [] -> SymSet.empty - | syms :: symses -> SymSet.union syms (symset_bigunion symses) + | [] -> Sym.Set.empty + | syms :: symses -> Sym.Set.union syms (symset_bigunion symses) let rec bound_by_pattern (CNPat (_loc, pat_)) = match pat_ with - | CNPat_sym s -> SymSet.singleton s - | CNPat_wild -> SymSet.empty + | CNPat_sym s -> Sym.Set.singleton s + | CNPat_wild -> Sym.Set.empty | CNPat_constructor (_, args) -> symset_bigunion (List.map (fun (_, p) -> bound_by_pattern p) args) let rec free_in_expr (CNExpr (_loc, expr_)) = match expr_ with - | CNExpr_const _ -> SymSet.empty - | CNExpr_var v -> SymSet.singleton v + | CNExpr_const _ -> Sym.Set.empty + | CNExpr_var v -> Sym.Set.singleton v | CNExpr_list es -> free_in_exprs es | CNExpr_memberof (e, _id) -> free_in_expr e | CNExpr_arrow (e, _id) -> free_in_expr e @@ -183,39 +181,39 @@ let rec free_in_expr (CNExpr (_loc, expr_)) = | CNExpr_arrayindexupdates (e, updates) -> free_in_exprs (e :: List.concat_map (fun (e1, e2) -> [ e1; e2 ]) updates) | CNExpr_binop (_binop, e1, e2) -> free_in_exprs [ e1; e2 ] - | CNExpr_sizeof _ -> SymSet.empty - | CNExpr_offsetof _ -> SymSet.empty + | CNExpr_sizeof _ -> Sym.Set.empty + | CNExpr_offsetof _ -> Sym.Set.empty | CNExpr_array_shift (e1, _ct, e2) -> free_in_exprs [ e1; e2 ] | CNExpr_membershift (e, _opt_tag, _id) -> free_in_expr e - | CNExpr_addr _ -> SymSet.empty + | CNExpr_addr _ -> Sym.Set.empty | CNExpr_cast (_bt, e) -> free_in_expr e | CNExpr_call (_id, es) -> free_in_exprs es | CNExpr_cons (_c, args) -> free_in_exprs (List.map snd args) - | CNExpr_each (s, _bt, _range, e) -> SymSet.remove s (free_in_expr e) + | CNExpr_each (s, _bt, _range, e) -> Sym.Set.remove s (free_in_expr e) | CNExpr_match (x, ms) -> let free_per_case = List.map - (fun (pat, body) -> SymSet.diff (free_in_expr body) (bound_by_pattern pat)) + (fun (pat, body) -> Sym.Set.diff (free_in_expr body) (bound_by_pattern pat)) ms in - SymSet.union (free_in_expr x) (symset_bigunion free_per_case) + Sym.Set.union (free_in_expr x) (symset_bigunion free_per_case) | CNExpr_let (s, e, body) -> - SymSet.union (free_in_expr e) (SymSet.remove s (free_in_expr body)) + Sym.Set.union (free_in_expr e) (Sym.Set.remove s (free_in_expr body)) | CNExpr_ite (e1, e2, e3) -> free_in_exprs [ e1; e2; e3 ] | CNExpr_good (_typ, e) -> free_in_expr e | CNExpr_deref e -> free_in_expr e - | CNExpr_value_of_c_atom (s, _) -> SymSet.singleton s + | CNExpr_value_of_c_atom (s, _) -> Sym.Set.singleton s | CNExpr_unchanged e -> free_in_expr e | CNExpr_at_env (e, _evaluation_scope) -> free_in_expr e | CNExpr_not e -> free_in_expr e | CNExpr_bnot e -> free_in_expr e | CNExpr_negate e -> free_in_expr e - | CNExpr_default _bt -> SymSet.empty + | CNExpr_default _bt -> Sym.Set.empty and free_in_exprs = function - | [] -> SymSet.empty - | e :: es -> SymSet.union (free_in_expr e) (free_in_exprs es) + | [] -> Sym.Set.empty + | e :: es -> Sym.Set.union (free_in_expr e) (free_in_exprs es) let rec translate_cn_base_type env (bTy : CF.Symbol.sym cn_base_type) = @@ -314,7 +312,7 @@ let do_decode_enum env loc sym = let add_function _loc sym func_sig env = - return { env with functions = SymMap.add sym func_sig env.functions } + return { env with functions = Sym.Map.add sym func_sig env.functions } let register_cn_functions env (defs : cn_function list) = @@ -429,13 +427,13 @@ module EffectfulTranslation = struct let lookup_datatype loc sym env = - match SymMap.find_opt sym env.datatypes with + match Sym.Map.find_opt sym env.datatypes with | Some info -> return info | None -> fail TypeErrors.{ loc; msg = TypeErrors.Unknown_datatype sym } let lookup_constr loc sym env = - match SymMap.find_opt sym env.datatype_constrs with + match Sym.Map.find_opt sym env.datatype_constrs with | Some info -> return info | None -> fail TypeErrors.{ loc; msg = TypeErrors.Unknown_datatype_constr sym } @@ -577,7 +575,7 @@ module EffectfulTranslation = struct | CNPat_wild -> return (env, locally_bound, IT.Pat (PWild, bt, loc)) | CNPat_sym s -> let env' = add_logical s bt env in - let locally_bound' = SymSet.add s locally_bound in + let locally_bound' = Sym.Set.add s locally_bound in return (env', locally_bound', IT.Pat (PSym s, bt, loc)) | CNPat_constructor (cons, args) -> let@ cons_info = lookup_constr loc cons env in @@ -644,7 +642,7 @@ module EffectfulTranslation = struct ("failed lookup of CNExpr_var " ^ Sym.pp_string sym) (Pp.list (fun (nm, _) -> Sym.pp nm) - (SymMap.bindings env.computationals)))); + (Sym.Map.bindings env.computationals)))); fail { loc; msg = Unknown_variable sym } | Some (bt, None) -> return (sym, bt) | Some (bt, Some renamed_sym) -> return (renamed_sym, bt) @@ -863,7 +861,7 @@ module EffectfulTranslation = struct let@ expr = trans evaluation_scope - (SymSet.add sym locally_bound) + (Sym.Set.add sym locally_bound) (add_logical sym BT.Integer env) e in @@ -892,7 +890,7 @@ module EffectfulTranslation = struct let@ body = trans evaluation_scope - (SymSet.add s locally_bound) + (Sym.Set.add s locally_bound) (add_logical s (IT.bt e) env) body in @@ -946,8 +944,8 @@ module EffectfulTranslation = struct trans (Some scope) locally_bound env e | CNExpr_deref e -> let@ () = - let locally_bound_in_e = SymSet.inter (free_in_expr e) locally_bound in - match SymSet.elements locally_bound_in_e with + let locally_bound_in_e = Sym.Set.inter (free_in_expr e) locally_bound in + match Sym.Set.elements locally_bound_in_e with | [] -> return () | s :: _ -> let msg = @@ -979,7 +977,7 @@ module EffectfulTranslation = struct in fail { loc; msg = Generic msg }) | CNExpr_value_of_c_atom (sym, C_kind_var) -> - assert (not (SymSet.mem sym locally_bound)); + assert (not (Sym.Set.mem sym locally_bound)); (* let@ o_v = match evaluation_scope with *) (* | Some scope -> *) (* let state = StringMap.find scope env.old_states in *) @@ -987,7 +985,7 @@ module EffectfulTranslation = struct (* Option.map (function *) (* | CVS_Value x -> x *) (* | CVS_Pointer_pointing_to x -> x *) - (* ) (SymMap.find_opt sym state.c_variable_state) *) + (* ) (Sym.Map.find_opt sym state.c_variable_state) *) (* in *) (* return o_v *) (* | None -> *) @@ -1008,7 +1006,7 @@ module EffectfulTranslation = struct fail { loc; msg = Generic msg } | Some v -> return v) | CNExpr_value_of_c_atom (sym, C_kind_enum) -> - assert (not (SymSet.mem sym locally_bound)); + assert (not (Sym.Set.mem sym locally_bound)); liftResultat (do_decode_enum env loc sym) in trans None @@ -1099,7 +1097,7 @@ module EffectfulTranslation = struct let translate_cn_let_resource__pred env res_loc sym (pred_loc, res, args) = - let@ args = ListM.mapM (translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (translate_cn_expr Sym.Set.empty env) args in let@ pname, ptr_expr, iargs, oargs_ty = translate_cn_res_info res_loc pred_loc env res args in @@ -1124,8 +1122,8 @@ module EffectfulTranslation = struct let translate_cn_let_resource__each env res_loc (q, bt, guard, pred_loc, res, args) = let@ bt' = check_quantified_base_type env pred_loc bt in let env_with_q = add_logical q bt' env in - let@ guard_expr = translate_cn_expr (SymSet.singleton q) env_with_q guard in - let@ args = ListM.mapM (translate_cn_expr (SymSet.singleton q) env_with_q) args in + let@ guard_expr = translate_cn_expr (Sym.Set.singleton q) env_with_q guard in + let@ args = ListM.mapM (translate_cn_expr (Sym.Set.singleton q) env_with_q) args in let@ pname, ptr_expr, iargs, oargs_ty = translate_cn_res_info res_loc pred_loc env_with_q res args in @@ -1161,13 +1159,13 @@ module EffectfulTranslation = struct let translate_cn_assrt env (loc, assrt) = match assrt with | CN_assert_exp e_ -> - let@ e = translate_cn_expr SymSet.empty env e_ in + let@ e = translate_cn_expr Sym.Set.empty env e_ in return (LC.T (IT.Surface.proj e)) | CN_assert_qexp (sym, bTy, e1_, e2_) -> let bt = translate_cn_base_type env bTy in let env_with_q = add_logical sym bt env in - let@ e1 = translate_cn_expr (SymSet.singleton sym) env_with_q e1_ in - let@ e2 = translate_cn_expr (SymSet.singleton sym) env_with_q e2_ in + let@ e1 = translate_cn_expr (Sym.Set.singleton sym) env_with_q e1_ in + let@ e2 = translate_cn_expr (Sym.Set.singleton sym) env_with_q e2_ in return (LC.Forall ((sym, SBT.proj bt), IT.impl_ (IT.Surface.proj e1, IT.Surface.proj e2) loc)) @@ -1192,7 +1190,7 @@ end let translate_cn_func_body env body = let handle = Pure.handle "Function definitions" in - let@ body = handle (ET.translate_cn_expr SymSet.empty env body) in + let@ body = handle (ET.translate_cn_expr Sym.Set.empty env body) in return (IT.Surface.proj body) @@ -1272,11 +1270,11 @@ module LocalState = struct (* currently the variable is a pointer to memory holding this value *) type state = - { c_variable_state : c_variable_state SymMap.t; + { c_variable_state : c_variable_state Sym.Map.t; pointee_values : IT.Surface.t STermMap.t } - let empty_state = { c_variable_state = SymMap.empty; pointee_values = STermMap.empty } + let empty_state = { c_variable_state = Sym.Map.empty; pointee_values = STermMap.empty } type states = { state : state; @@ -1291,7 +1289,7 @@ module LocalState = struct let add_c_variable_state c_sym cvs { state; old_states } = { state = - { state with c_variable_state = SymMap.add c_sym cvs state.c_variable_state }; + { state with c_variable_state = Sym.Map.add c_sym cvs state.c_variable_state }; old_states } @@ -1325,7 +1323,7 @@ module LocalState = struct (function | CVS_Value (sym', sbt) -> IT.sym_ (sym', sbt, loc) | CVS_Pointer_pointing_to x -> x) - (SymMap.find_opt sym variable_state) + (Sym.Map.find_opt sym variable_state) in aux (k o_v) | E.Deref (_loc, it, scope, k) -> @@ -1357,7 +1355,7 @@ let translate_cn_clause env clause = let st' = add_pointee_values pointee_vals st in translate_cn_clause_aux env' st' acc' cl | CN_letExpr (loc, sym, e_, cl) -> - let@ e = handle st (ET.translate_cn_expr SymSet.empty env e_) in + let@ e = handle st (ET.translate_cn_expr Sym.Set.empty env e_) in let acc' z = acc (LAT.mDefine (sym, IT.Surface.proj e, (loc, None)) z) in translate_cn_clause_aux (add_logical sym (IT.basetype e) env) st acc' cl | CN_assert (loc, assrt, cl) -> @@ -1365,7 +1363,7 @@ let translate_cn_clause env clause = let acc' z = acc (LAT.mConstraint (lc, (loc, None)) z) in translate_cn_clause_aux env st acc' cl | CN_return (_loc, e_) -> - let@ e = handle st (ET.translate_cn_expr SymSet.empty env e_) in + let@ e = handle st (ET.translate_cn_expr Sym.Set.empty env e_) in let e = IT.Surface.proj e in acc (LAT.I e) in @@ -1380,7 +1378,7 @@ let translate_cn_clauses env clauses = return (RP.{ loc; guard = IT.bool_ true here; packing_ft = cl } :: acc) | CN_if (loc, e_, cl_, clauses') -> let@ e = - Pure.handle "Predicate guards" (ET.translate_cn_expr SymSet.empty env e_) + Pure.handle "Predicate guards" (ET.translate_cn_expr Sym.Set.empty env e_) in let@ cl = translate_cn_clause env cl_ in self (RP.{ loc; guard = IT.Surface.proj e; packing_ft = cl } :: acc) clauses' @@ -1443,7 +1441,7 @@ let rec make_lrt_generic env st = env, st ) | CN_cletExpr (loc, name, expr) :: ensures -> - let@ expr = handle st (ET.translate_cn_expr SymSet.empty env expr) in + let@ expr = handle st (ET.translate_cn_expr Sym.Set.empty env expr) in let@ lrt, env, st = make_lrt_generic (add_logical name (IT.bt expr) env) st ensures in return (LRT.mDefine (name, IT.Surface.proj expr, (loc, None)) lrt, env, st) | CN_cconstr (loc, constr) :: ensures -> @@ -1542,7 +1540,7 @@ module UsingLoads = struct (function | LocalState.CVS_Value (sym', sbt) -> IT.sym_ (sym', sbt, loc) | LocalState.CVS_Pointer_pointing_to x -> x) - (SymMap.find_opt sym variable_state) + (Sym.Map.find_opt sym variable_state) in aux (k o_v) | None -> @@ -1583,7 +1581,7 @@ let translate_cn_statement (let open Effectful.Make (E) in match stmt_ with | CN_pack_unpack (pack_unpack, pred, args) -> - let@ args = ListM.mapM (ET.translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (ET.translate_cn_expr Sym.Set.empty env) args in let@ name, pointer, iargs, _oargs_ty = ET.translate_cn_res_info loc loc env pred args in @@ -1597,7 +1595,7 @@ let translate_cn_statement in return (Statement (loc, stmt)) | CN_to_from_bytes (to_from, pred, args) -> - let@ args = ListM.mapM (ET.translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (ET.translate_cn_expr Sym.Set.empty env) args in let@ name, pointer, iargs, _oargs_ty = ET.translate_cn_res_info loc loc env pred args in @@ -1614,7 +1612,7 @@ let translate_cn_statement let@ assrt = ET.translate_cn_assrt env (loc, assrt) in return (Statement (loc, Have assrt)) | CN_instantiate (to_instantiate, expr) -> - let@ expr = ET.translate_cn_expr SymSet.empty env expr in + let@ expr = ET.translate_cn_expr Sym.Set.empty env expr in let expr = IT.Surface.proj expr in let to_instantiate = match to_instantiate with @@ -1627,7 +1625,7 @@ let translate_cn_statement let@ e = ET.translate_cn_assrt env (loc, e) in return (Statement (loc, Split_case e)) | CN_extract (attrs, to_extract, expr) -> - let@ expr = ET.translate_cn_expr SymSet.empty env expr in + let@ expr = ET.translate_cn_expr Sym.Set.empty env expr in let expr = IT.Surface.proj expr in let to_extract = match to_extract with @@ -1640,18 +1638,18 @@ let translate_cn_statement in return (Statement (loc, Extract (attrs, to_extract, expr))) | CN_unfold (s, args) -> - let@ args = ListM.mapM (ET.translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (ET.translate_cn_expr Sym.Set.empty env) args in let args = List.map IT.Surface.proj args in return (Statement (loc, Unfold (s, args))) | CN_assert_stmt e -> let@ e = ET.translate_cn_assrt env (loc, e) in return (Statement (loc, Assert e)) | CN_apply (s, args) -> - let@ args = ListM.mapM (ET.translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (ET.translate_cn_expr Sym.Set.empty env) args in let args = List.map IT.Surface.proj args in return (Statement (loc, Apply (s, args))) | CN_inline nms -> return (Statement (loc, Inline nms)) | CN_print expr -> - let@ expr = ET.translate_cn_expr SymSet.empty env expr in + let@ expr = ET.translate_cn_expr Sym.Set.empty env expr in let expr = IT.Surface.proj expr in return (Statement (loc, Print expr))) diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index 1d8e93046..4d1314c75 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -6,7 +6,6 @@ module RE = Resources module LC = LogicalConstraints module LCSet = Set.Make (LC) module Loc = Locations -module SymMap = Map.Make (Sym) module IntMap = Map.Make (Int) type l_info = Locations.t * Pp.document Lazy.t @@ -36,8 +35,8 @@ type resource_history = } type t = - { computational : (basetype_or_value * l_info) SymMap.t; - logical : (basetype_or_value * l_info) SymMap.t; + { computational : (basetype_or_value * l_info) Sym.Map.t; + logical : (basetype_or_value * l_info) Sym.Map.t; resources : (RE.t * int) list * int; resource_history : resource_history IntMap.t; constraints : LCSet.t; @@ -49,9 +48,9 @@ let empty = let logical = let loc_str = __FILE__ ^ ":" ^ string_of_int __LINE__ in let l_info = (Locations.other loc_str, lazy (Pp.string loc_str)) in - SymMap.(empty |> add Alloc.History.sym (BaseType Alloc.History.bt, l_info)) + Sym.Map.(empty |> add Alloc.History.sym (BaseType Alloc.History.bt, l_info)) in - { computational = SymMap.empty; + { computational = Sym.Map.empty; logical; resources = ([], 0); resource_history = IntMap.empty; @@ -71,7 +70,7 @@ let pp_basetype_or_value = function let pp_variable_bindings bindings = Pp.list (fun (sym, (binding, _)) -> typ (Sym.pp sym) (pp_basetype_or_value binding)) - (SymMap.bindings bindings) + (Sym.Map.bindings bindings) let pp_constraints constraints = @@ -91,27 +90,27 @@ let pp (ctxt : t) = ^/^ item "constraints" (pp_constraints ctxt.constraints) -let bound_a s ctxt = SymMap.exists (fun s' _ -> Sym.equal s s') ctxt.computational +let bound_a s ctxt = Sym.Map.exists (fun s' _ -> Sym.equal s s') ctxt.computational -let bound_l s ctxt = SymMap.exists (fun s' _ -> Sym.equal s s') ctxt.logical +let bound_l s ctxt = Sym.Map.exists (fun s' _ -> Sym.equal s s') ctxt.logical let bound s ctxt = bound_a s ctxt || bound_l s ctxt let get_a s ctxt = - match SymMap.find_opt s ctxt.computational with + match Sym.Map.find_opt s ctxt.computational with | Some (bt_v, _) -> bt_v | None -> failwith ("Context.get_a: not found: " ^ Pp.plain (Sym.pp_debug s)) let get_l s ctxt = - match SymMap.find_opt s ctxt.logical with + match Sym.Map.find_opt s ctxt.logical with | Some (bt_v, _) -> bt_v | None -> failwith ("Context.get_l: not found: " ^ Pp.plain (Sym.pp_debug s)) let add_a_binding s binding info ctxt = if bound s ctxt then failwith ("already bound: " ^ Sym.pp_string s); - { ctxt with computational = SymMap.add s (binding, info) ctxt.computational } + { ctxt with computational = Sym.Map.add s (binding, info) ctxt.computational } let add_a s bt info ctxt = add_a_binding s (BaseType bt) info ctxt @@ -120,7 +119,7 @@ let add_a_value s value info ctxt = add_a_binding s (Value value) info ctxt let add_l_binding s binding info ctxt = if bound s ctxt then failwith ("already bound: " ^ Sym.pp_string s); - { ctxt with logical = SymMap.add s (binding, info) ctxt.logical } + { ctxt with logical = Sym.Map.add s (binding, info) ctxt.logical } let add_l s bt info ctxt = add_l_binding s (BaseType bt) info ctxt @@ -131,12 +130,12 @@ let add_l_value s value info ctxt = add_l_binding s (Value value) info ctxt attached to s: s will still be bound "logically", but out of scope as far as the Core program goes. *) let remove_a s ctxt = - let binding, info = SymMap.find s ctxt.computational in + let binding, info = Sym.Map.find s ctxt.computational in add_l_binding s binding info - { ctxt with computational = SymMap.remove s ctxt.computational } + { ctxt with computational = Sym.Map.remove s ctxt.computational } let add_c c (ctxt : t) = @@ -246,13 +245,13 @@ let json (ctxt : t) : Yojson.Safe.t = List.map (fun (sym, (binding, _)) -> `Assoc [ ("name", Sym.json sym); ("type", basetype_or_value binding) ]) - (SymMap.bindings ctxt.computational) + (Sym.Map.bindings ctxt.computational) in let logical = List.map (fun (sym, (binding, _)) -> `Assoc [ ("name", Sym.json sym); ("type", basetype_or_value binding) ]) - (SymMap.bindings ctxt.logical) + (Sym.Map.bindings ctxt.logical) in let resources = List.map RE.json (get_rs ctxt) in let constraints = List.map LC.json (LCSet.elements ctxt.constraints) in @@ -275,14 +274,14 @@ let not_given_to_solver ctxt = filter LogicalConstraints.is_forall (LCSet.elements ctxt.constraints) in let funs = - SymMap.bindings - (SymMap.filter + Sym.Map.bindings + (Sym.Map.filter (fun _ v -> not (LogicalFunctions.given_to_solver v)) global.logical_functions) in let preds = - SymMap.bindings - (SymMap.filter + Sym.Map.bindings + (Sym.Map.filter (fun _ v -> not (ResourcePredicates.given_to_solver v)) global.resource_predicates) in diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 2c3836685..3d8bb6977 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -11,8 +11,6 @@ module IT = IndexTerms module IdMap = Map.Make (Id) module SBT = BaseTypes.Surface module Mu = Mucore -module SymMap = Map.Make (Sym) -module SymSet = Set.Make (Sym) (* Short forms *) module Desugar = struct @@ -895,7 +893,9 @@ let make_largs f_i = ((name, (pt_ret, SBT.proj oa_bt)), (loc, None)) (Mu.mConstraints lcs lat)) | Cn.CN_cletExpr (loc, name, expr) :: conditions -> - let@ expr = C.LocalState.handle st (C.ET.translate_cn_expr SymSet.empty env expr) in + let@ expr = + C.LocalState.handle st (C.ET.translate_cn_expr Sym.Set.empty env expr) + in let@ lat = aux (C.add_logical name (IT.bt expr) env) st conditions in return (Mu.mDefine ((name, IT.Surface.proj expr), (loc, None)) lat) | Cn.CN_cconstr (loc, constr) :: conditions -> @@ -1267,7 +1267,7 @@ let normalise_fun_map_decl let@ ensures, _ret_d_st = desugar_conds ret_d_st (List.map snd ensures) in debug 6 (lazy (string "desugared ensures conds")); let@ spec_req, spec_ens, env = - match SymMap.find_opt fname fun_specs with + match Sym.Map.find_opt fname fun_specs with | Some (_, spec) -> let@ () = match defn_spec_sites with @@ -1345,7 +1345,7 @@ let normalise_fun_map_decl return (Some (Mu.Proc { loc; args_and_body; trusted; desugared_spec }, mk_functions)) | Mi_ProcDecl (loc, ret_bt, _bts) -> - (match SymMap.find_opt fname fun_specs with + (match Sym.Map.find_opt fname fun_specs with | Some (_ail_marker, (spec : (CF.Symbol.sym, Ctype.ctype) Cn.cn_fun_spec)) -> let@ () = check_against_core_bt loc ret_bt (Memory.bt_of_sct (convert_ct loc ret_ct)) @@ -1551,9 +1551,9 @@ let normalise_file ~inherit_loc ((fin_markers_env : CAE.fin_markers_env), ail_pr let env = List.fold_left register_glob env globs in let fun_specs_map = List.fold_right - (fun (id, spec) acc -> SymMap.add spec.Cn.cn_spec_name (id, spec) acc) + (fun (id, spec) acc -> Sym.Map.add spec.Cn.cn_spec_name (id, spec) acc) ail_prog.cn_fun_specs - SymMap.empty + Sym.Map.empty in let@ funs, mk_functions = normalise_fun_map @@ -1577,7 +1577,7 @@ let normalise_file ~inherit_loc ((fin_markers_env : CAE.fin_markers_env), ail_pr }) file.mi_funinfo in - let stdlib_syms = SymSet.of_list (List.map fst (Pmap.bindings_list file.mi_stdlib)) in + let stdlib_syms = Sym.Set.of_list (List.map fst (Pmap.bindings_list file.mi_stdlib)) in let datatypes = List.map (translate_datatype env) ail_prog.cn_datatypes in let file = Mu. diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index 9297d5cf2..4429e9b0f 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -8,8 +8,6 @@ module LC = LogicalConstraints module LF = LogicalFunctions module LAT = LogicalArgumentTypes module LS = LogicalSorts -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module StringMap = Map.Make (String) module C = Context module Loc = Locations @@ -51,7 +49,7 @@ let relevant_predicate_clauses global name req = let open Global in let open ResourcePredicates in let clauses = - let defs = SymMap.bindings global.resource_predicates in + let defs = Sym.Map.bindings global.resource_predicates in List.concat_map (fun (nm, def) -> match def.clauses with @@ -83,8 +81,8 @@ let subterms_without_bound_variables bindings = (fun bindings acc t -> let pats = List.map fst bindings in let bound = List.concat_map bound_by_pattern pats in - let bound = SymSet.of_list (List.map fst bound) in - if SymSet.(is_empty (inter bound (IT.free_vars t))) then + let bound = Sym.Set.of_list (List.map fst bound) in + if Sym.Set.(is_empty (inter bound (IT.free_vars t))) then ITSet.add t acc else acc) @@ -237,8 +235,8 @@ let state ctxt log model_with_q extras = in ITSet.of_list (List.map (fun (s, ls) -> make s ls) quantifier_counter_model - @ List.filter_map basetype_binding (SymMap.bindings ctxt.computational) - @ List.filter_map basetype_binding (SymMap.bindings ctxt.logical)) + @ List.filter_map basetype_binding (Sym.Map.bindings ctxt.computational) + @ List.filter_map basetype_binding (Sym.Map.bindings ctxt.logical)) in let unproven = match extras.unproven_constraint with diff --git a/backend/cn/lib/false.ml b/backend/cn/lib/false.ml index 25798d91c..9455323f2 100644 --- a/backend/cn/lib/false.ml +++ b/backend/cn/lib/false.ml @@ -1,12 +1,11 @@ open Pp -module SymSet = Set.Make (Sym) type t = False (* [@@deriving eq, ord] *) let subst _substitution = function False -> False -let free_vars = function False -> SymSet.empty +let free_vars = function False -> Sym.Set.empty let pp = function False -> if !unicode then !^"\u{22A5}" else !^"false" diff --git a/backend/cn/lib/false.mli b/backend/cn/lib/false.mli index 75363d614..624a78eb4 100644 --- a/backend/cn/lib/false.mli +++ b/backend/cn/lib/false.mli @@ -7,6 +7,4 @@ val subst : 'a -> t -> t val pp : t -> Pp.document -module SymSet : Set.S with type elt = Sym.t - -val free_vars : t -> SymSet.t +val free_vars : t -> Sym.Set.t diff --git a/backend/cn/lib/global.ml b/backend/cn/lib/global.ml index 9194de9c2..c5bbe40e6 100644 --- a/backend/cn/lib/global.ml +++ b/backend/cn/lib/global.ml @@ -1,44 +1,42 @@ open Pp -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module IdMap = Map.Make (Id) module RT = ReturnTypes module AT = ArgumentTypes type t = { struct_decls : Memory.struct_decls; - datatypes : BaseTypes.dt_info SymMap.t; - datatype_constrs : BaseTypes.constr_info SymMap.t; + datatypes : BaseTypes.dt_info Sym.Map.t; + datatype_constrs : BaseTypes.constr_info Sym.Map.t; datatype_order : Sym.t list list option; - fun_decls : (Locations.t * AT.ft option * Sctypes.c_concrete_sig) SymMap.t; - resource_predicates : ResourcePredicates.definition SymMap.t; - logical_functions : LogicalFunctions.definition SymMap.t; - lemmata : (Locations.t * AT.lemmat) SymMap.t + fun_decls : (Locations.t * AT.ft option * Sctypes.c_concrete_sig) Sym.Map.t; + resource_predicates : ResourcePredicates.definition Sym.Map.t; + logical_functions : LogicalFunctions.definition Sym.Map.t; + lemmata : (Locations.t * AT.lemmat) Sym.Map.t } let empty = - { struct_decls = SymMap.empty; - datatypes = SymMap.empty; - datatype_constrs = SymMap.empty; + { struct_decls = Sym.Map.empty; + datatypes = Sym.Map.empty; + datatype_constrs = Sym.Map.empty; datatype_order = None; - fun_decls = SymMap.empty; + fun_decls = Sym.Map.empty; resource_predicates = - SymMap.(empty |> add Alloc.Predicate.sym ResourcePredicates.alloc); - logical_functions = SymMap.empty; - lemmata = SymMap.empty + Sym.Map.(empty |> add Alloc.Predicate.sym ResourcePredicates.alloc); + logical_functions = Sym.Map.empty; + lemmata = Sym.Map.empty } -let get_resource_predicate_def global id = SymMap.find_opt id global.resource_predicates +let get_resource_predicate_def global id = Sym.Map.find_opt id global.resource_predicates -let get_logical_function_def global id = SymMap.find_opt id global.logical_functions +let get_logical_function_def global id = Sym.Map.find_opt id global.logical_functions -let get_fun_decl global sym = SymMap.find_opt sym global.fun_decls +let get_fun_decl global sym = Sym.Map.find_opt sym global.fun_decls -let get_lemma global sym = SymMap.find_opt sym global.lemmata +let get_lemma global sym = Sym.Map.find_opt sym global.lemmata let sym_map_from_bindings xs = - List.fold_left (fun m (nm, x) -> SymMap.add nm x m) SymMap.empty xs + List.fold_left (fun m (nm, x) -> Sym.Map.add nm x m) Sym.Map.empty xs let pp_struct_layout (tag, layout) = @@ -59,19 +57,19 @@ let pp_struct_layout (tag, layout) = layout) -let pp_struct_decls decls = Pp.list pp_struct_layout (SymMap.bindings decls) +let pp_struct_decls decls = Pp.list pp_struct_layout (Sym.Map.bindings decls) let pp_fun_decl (sym, (_, t, _)) = item (plain (Sym.pp sym)) (Pp.option (AT.pp RT.pp) "(no spec)" t) -let pp_fun_decls decls = flow_map hardline pp_fun_decl (SymMap.bindings decls) +let pp_fun_decls decls = flow_map hardline pp_fun_decl (Sym.Map.bindings decls) let pp_resource_predicate_definitions defs = separate_map hardline (fun (name, def) -> item (Sym.pp_string name) (ResourcePredicates.pp_definition def)) - (SymMap.bindings defs) + (Sym.Map.bindings defs) let pp global = @@ -84,15 +82,15 @@ let pp global = let mutual_datatypes (global : t) tag = let deps tag = - let info = SymMap.find tag global.datatypes in + let info = Sym.Map.find tag global.datatypes in info.all_params |> List.filter_map (fun (_, bt) -> BaseTypes.is_datatype_bt bt) in let rec seek tags = function | [] -> tags | new_tag :: new_tags -> - if SymSet.mem new_tag tags then + if Sym.Set.mem new_tag tags then seek tags new_tags else - seek (SymSet.add new_tag tags) (deps new_tag @ new_tags) + seek (Sym.Set.add new_tag tags) (deps new_tag @ new_tags) in - seek SymSet.empty [ tag ] |> SymSet.elements + seek Sym.Set.empty [ tag ] |> Sym.Set.elements diff --git a/backend/cn/lib/indexTerms.ml b/backend/cn/lib/indexTerms.ml index cdf1bd561..97891cc62 100644 --- a/backend/cn/lib/indexTerms.ml +++ b/backend/cn/lib/indexTerms.ml @@ -1,7 +1,5 @@ module BT = BaseTypes module CF = Cerb_frontend -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) include Terms let equal = equal_annot BT.equal @@ -63,14 +61,14 @@ let rec bound_by_pattern (Pat (pat_, bt, _)) = List.concat_map (fun (_id, pat) -> bound_by_pattern pat) args -let rec free_vars_bts (it : 'a annot) : BT.t SymMap.t = +let rec free_vars_bts (it : 'a annot) : BT.t Sym.Map.t = match term it with - | Const _ -> SymMap.empty - | Sym s -> SymMap.singleton s (bt it) + | Const _ -> Sym.Map.empty + | Sym s -> Sym.Map.singleton s (bt it) | Unop (_uop, t1) -> free_vars_bts t1 | Binop (_bop, t1, t2) -> free_vars_bts_list [ t1; t2 ] | ITE (t1, t2, t3) -> free_vars_bts_list [ t1; t2; t3 ] - | EachI ((_, (s, _), _), t) -> SymMap.remove s (free_vars_bts t) + | EachI ((_, (s, _), _), t) -> Sym.Map.remove s (free_vars_bts t) | Tuple ts -> free_vars_bts_list ts | NthTuple (_, t) -> free_vars_bts t | Struct (_tag, members) -> free_vars_bts_list (List.map snd members) @@ -84,9 +82,9 @@ let rec free_vars_bts (it : 'a annot) : BT.t SymMap.t = | ArrayShift { base; ct = _; index } -> free_vars_bts_list [ base; index ] | CopyAllocId { addr; loc } -> free_vars_bts_list [ addr; loc ] | HasAllocId loc -> free_vars_bts_list [ loc ] - | SizeOf _t -> SymMap.empty - | OffsetOf (_tag, _member) -> SymMap.empty - | Nil _bt -> SymMap.empty + | SizeOf _t -> Sym.Map.empty + | OffsetOf (_tag, _member) -> Sym.Map.empty + | Nil _bt -> Sym.Map.empty | Cons (t1, t2) -> free_vars_bts_list [ t1; t2 ] | Head t -> free_vars_bts t | Tail t -> free_vars_bts t @@ -99,25 +97,25 @@ let rec free_vars_bts (it : 'a annot) : BT.t SymMap.t = | MapConst (_bt, t) -> free_vars_bts t | MapSet (t1, t2, t3) -> free_vars_bts_list [ t1; t2; t3 ] | MapGet (t1, t2) -> free_vars_bts_list [ t1; t2 ] - | MapDef ((s, _bt), t) -> SymMap.remove s (free_vars_bts t) + | MapDef ((s, _bt), t) -> Sym.Map.remove s (free_vars_bts t) | Apply (_pred, ts) -> free_vars_bts_list ts | Let ((nm, t1), t2) -> - SymMap.union + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) (free_vars_bts t1) - (SymMap.remove nm (free_vars_bts t2)) + (Sym.Map.remove nm (free_vars_bts t2)) | Match (e, cases) -> let rec aux acc = function | [] -> acc | (pat, body) :: cases -> - let bound = SymSet.of_list (List.map fst (bound_by_pattern pat)) in + let bound = Sym.Set.of_list (List.map fst (bound_by_pattern pat)) in let more = - SymMap.filter (fun x _ -> not (SymSet.mem x bound)) (free_vars_bts body) + Sym.Map.filter (fun x _ -> not (Sym.Set.mem x bound)) (free_vars_bts body) in aux - (SymMap.union + (Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) @@ -129,34 +127,34 @@ let rec free_vars_bts (it : 'a annot) : BT.t SymMap.t = | Constructor (_s, args) -> free_vars_bts_list (List.map snd args) -and free_vars_bts_list : 'a annot list -> BT.t SymMap.t = +and free_vars_bts_list : 'a annot list -> BT.t Sym.Map.t = fun xs -> List.fold_left (fun ss t -> - SymMap.union + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) ss (free_vars_bts t)) - SymMap.empty + Sym.Map.empty xs -let free_vars (it : 'a annot) : SymSet.t = - it |> free_vars_bts |> SymMap.bindings |> List.map fst |> SymSet.of_list +let free_vars (it : 'a annot) : Sym.Set.t = + it |> free_vars_bts |> Sym.Map.bindings |> List.map fst |> Sym.Set.of_list -let free_vars_ (t_ : 'a Terms.term) : SymSet.t = +let free_vars_ (t_ : 'a Terms.term) : Sym.Set.t = IT (t_, Unit, Locations.other "") |> free_vars_bts - |> SymMap.bindings + |> Sym.Map.bindings |> List.map fst - |> SymSet.of_list + |> Sym.Set.of_list -let free_vars_list (its : 'a annot list) : SymSet.t = - its |> free_vars_bts_list |> SymMap.bindings |> List.map fst |> SymSet.of_list +let free_vars_list (its : 'a annot list) : Sym.Set.t = + its |> free_vars_bts_list |> Sym.Map.bindings |> List.map fst |> Sym.Set.of_list type 'bt bindings = ('bt pattern * 'bt annot option) list @@ -261,15 +259,15 @@ let mentions_call f = fold_subterms (fun _binders acc it -> acc || is_call f it) let mentions_good ct = fold_subterms (fun _binders acc it -> acc || is_good ct it) false let preds_of t = - let add_p s = function IT (Apply (id, _), _, _) -> SymSet.add id s | _ -> s in - fold_subterms (fun _ -> add_p) SymSet.empty t + let add_p s = function IT (Apply (id, _), _, _) -> Sym.Set.add id s | _ -> s in + fold_subterms (fun _ -> add_p) Sym.Set.empty t let json it : Yojson.Safe.t = `String (Pp.plain (pp it)) let free_vars_with_rename = function | `Term t -> free_vars t - | `Rename s -> SymSet.singleton s + | `Rename s -> Sym.Set.singleton s let make_rename ~from ~to_ = Subst.make free_vars_with_rename [ (from, `Rename to_) ] @@ -337,7 +335,7 @@ let rec subst (su : [ `Term of t | `Rename of Sym.t ] Subst.t) (IT (it, bt, loc) IT (MapDef ((s, abt), subst su body), bt, loc) | Apply (name, args) -> IT (Apply (name, List.map (subst su) args), bt, loc) | Let ((name, t1), t2) -> - if SymSet.mem substitute_lets_flag su.flags then ( + if Sym.Set.mem substitute_lets_flag su.flags then ( let t1 = subst su t1 in subst (Subst.add free_vars_with_rename (name, `Term t1) su) t2) else ( @@ -358,7 +356,7 @@ and alpha_rename s body = and suitably_alpha_rename syms s body = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename s body else (s, body) @@ -388,7 +386,7 @@ and suitably_alpha_rename_pattern su (Pat (pat_, bt, loc), body) = let substitute_lets = - let flags = SymSet.of_list [ substitute_lets_flag ] in + let flags = Sym.Set.of_list [ substitute_lets_flag ] in subst { (make_subst []) with flags } @@ -690,7 +688,7 @@ let ( %. ) struct_decls t member = in let member_bt = match - List.assoc_opt Id.equal member (Memory.member_types (SymMap.find tag struct_decls)) + List.assoc_opt Id.equal member (Memory.member_types (Sym.Map.find tag struct_decls)) with | Some sct -> Memory.bt_of_sct sct | None -> @@ -1009,7 +1007,7 @@ let value_check mode (struct_layouts : Memory.struct_decls) ct about loc = let member_it = member_ ~member_bt (about, member) loc in Some (aux mct member_it) | None -> None) - (SymMap.find tag struct_layouts)) + (Sym.Map.find tag struct_layouts)) loc | Function _ -> Cerb_debug.error "todo: function types" in @@ -1061,8 +1059,8 @@ let rec wrap_bindings_match bs default_v v = (match wrap_bindings_match bindings default_v v with | None -> None | Some v2 -> - let pat_ss = SymSet.of_list (List.map fst (bound_by_pattern pat)) in - if SymSet.is_empty (SymSet.inter pat_ss (free_vars v2)) then + let pat_ss = Sym.Set.of_list (List.map fst (bound_by_pattern pat)) in + if Sym.Set.is_empty (Sym.Set.inter pat_ss (free_vars v2)) then Some v2 else ( match x with diff --git a/backend/cn/lib/interval.ml b/backend/cn/lib/interval.ml index f2dd90264..b5b628370 100644 --- a/backend/cn/lib/interval.ml +++ b/backend/cn/lib/interval.ml @@ -191,7 +191,7 @@ module Solver = struct let interval_for (eval : IT.t -> IT.t option) q tyi = let is_q i = match IT.term i with Sym y -> Sym.equal q y | _ -> false in let eval_k e = - if IT.SymSet.mem q (IT.free_vars e) then + if Sym.Set.mem q (IT.free_vars e) then None else Option.bind (eval e) (fun v -> diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index 4728398d9..e4e3088a2 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -12,8 +12,6 @@ module LC = LogicalConstraints module IdSet = Set.Make (Id) module StringSet = Set.Make (String) module StringMap = Map.Make (String) -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module StringList = struct type t = string list @@ -260,7 +258,7 @@ let struct_layout_field_bts xs = let get_struct_xs struct_decls tag = - match SymMap.find_opt tag struct_decls with + match Sym.Map.find_opt tag struct_decls with | Some def -> struct_layout_field_bts def | None -> fail "undefined struct" (Sym.pp tag) @@ -305,12 +303,12 @@ let add_list_mono_datatype (bt, nm) global = let tl = Id.id ("tl_of_" ^ bt_name) in let mems = [ (hd, bt); (tl, BT.Datatype nm) ] in let datatypes = - SymMap.add nm Dt.{ constrs = [ nil; cons ]; all_params = mems } global.datatypes + Sym.Map.add nm Dt.{ constrs = [ nil; cons ]; all_params = mems } global.datatypes in let datatype_constrs = global.datatype_constrs - |> SymMap.add nil Dt.{ params = []; datatype_tag = nm } - |> SymMap.add cons Dt.{ params = mems; datatype_tag = nm } + |> Sym.Map.add nil Dt.{ params = []; datatype_tag = nm } + |> Sym.Map.add cons Dt.{ params = mems; datatype_tag = nm } in { global with datatypes; datatype_constrs } @@ -326,13 +324,13 @@ let monomorphise_dt_lists global = let dt_lists = function BT.List (BT.Datatype sym) -> Some sym | _ -> None in let module Dt = BT.Datatype in let all_dt_types = - SymMap.fold + Sym.Map.fold (fun _ dt_info ss -> List.filter_map dt_lists (List.map snd dt_info.Dt.all_params) @ ss) global.Global.datatypes [] in - let uniq_dt_types = SymSet.elements (SymSet.of_list all_dt_types) in + let uniq_dt_types = Sym.Set.elements (Sym.Set.of_list all_dt_types) in let new_sym sym = (sym, Sym.fresh_named ("list_of_" ^ Sym.pp_string sym)) in let new_syms = List.map new_sym uniq_dt_types in let list_mono = List.map (fun (s1, s2) -> (BT.Datatype s1, s2)) new_syms in @@ -340,12 +338,12 @@ let monomorphise_dt_lists global = let map_bt bt = Option.value ~default:bt (mono_list_bt list_mono bt) in let map_mems = List.map (fun (nm, bt) -> (nm, map_bt bt)) in let datatypes = - SymMap.map + Sym.Map.map (fun info -> Dt.{ info with all_params = map_mems info.all_params }) global.Global.datatypes in let datatype_constrs = - SymMap.map + Sym.Map.map (fun info -> Dt.{ info with params = map_mems info.params }) global.Global.datatype_constrs in @@ -364,7 +362,7 @@ let rec new_nm s nms i = let alpha_rename_if_pp_same s body = let vs = IT.free_vars body in let other_nms = - List.filter (fun sym -> not (Sym.equal sym s)) (SymSet.elements vs) + List.filter (fun sym -> not (Sym.equal sym s)) (Sym.Set.elements vs) |> List.map Sym.pp_string in if List.exists (String.equal (Sym.pp_string s)) other_nms then ( @@ -402,14 +400,14 @@ let it_adjust (global : Global.t) it = | IT.EachI ((i1, (s, bt), i2), x) -> let x = f x in let s, x, vs = alpha_rename_if_pp_same s x in - if not (SymSet.mem s vs) then ( + if not (Sym.Set.mem s vs) then ( assert (i1 <= i2); x) else IT.eachI_ (i1, (s, bt), i2) x loc | IT.Apply (name, args) -> let open LogicalFunctions in - let def = SymMap.find name global.logical_functions in + let def = Sym.Map.find name global.logical_functions in (match (def.definition, def.emit_coq) with | Def body, false -> f (open_fun def.args body args) | _ -> t) @@ -430,7 +428,7 @@ let it_adjust (global : Global.t) it = let nm, y, vs = alpha_rename_if_pp_same nm y in if Option.is_some (IT.is_sym x) then IT.subst (IT.make_subst [ (nm, x) ]) y - else if not (SymSet.mem nm vs) then + else if not (Sym.Set.mem nm vs) then y else IT.let_ ((nm, x), y) loc @@ -442,7 +440,7 @@ let it_adjust (global : Global.t) it = let fun_prop_ret (global : Global.t) nm = - match SymMap.find_opt nm global.logical_functions with + match Sym.Map.find_opt nm global.logical_functions with | None -> fail "fun_prop_ret: not found" (Sym.pp nm) | Some def -> let open LogicalFunctions in @@ -601,7 +599,7 @@ and ensure_datatype (global : Global.t) (list_mono : list_mono) loc dt_tag = (lazy (let open Pp in let cons_line dt_tag c_tag = - let info = SymMap.find c_tag global.datatype_constrs in + let info = Sym.Map.find c_tag global.datatype_constrs in let@ argTs = ListM.mapM (fun (_, bt) -> bt_to_coq2 bt) info.params in return (!^" | " @@ -612,7 +610,7 @@ and ensure_datatype (global : Global.t) (list_mono : list_mono) loc dt_tag = let@ dt_eqs = ListM.mapM (fun dt_tag -> - let info = SymMap.find dt_tag global.datatypes in + let info = Sym.Map.find dt_tag global.datatypes in let@ c_lines = ListM.mapM (cons_line dt_tag) info.constrs in return (!^" " @@ -638,11 +636,11 @@ and ensure_datatype (global : Global.t) (list_mono : list_mono) loc dt_tag = let ensure_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let@ () = ensure_datatype global list_mono loc dt_tag in let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.pp_string mem_tag in - let dt_info = SymMap.find dt_tag global.Global.datatypes in + let dt_info = Sym.Map.find dt_tag global.Global.datatypes in let inf = (loc, Pp.typ (Pp.string "datatype acc for") (Sym.pp dt_tag)) in let@ bt_doc = bt_to_coq global list_mono inf bt in let cons_line c = - let c_info = SymMap.find c global.Global.datatype_constrs in + let c_info = Sym.Map.find c global.Global.datatype_constrs in let pats = List.map (fun (m2, _) -> @@ -685,9 +683,9 @@ let ensure_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let ensure_single_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let@ () = ensure_datatype global list_mono loc dt_tag in let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.pp_string mem_tag in - let dt_info = SymMap.find dt_tag global.Global.datatypes in + let dt_info = Sym.Map.find dt_tag global.Global.datatypes in let cons_line c = - let c_info = SymMap.find c global.Global.datatype_constrs in + let c_info = Sym.Map.find c global.Global.datatype_constrs in let pats = List.map (fun (m2, _) -> @@ -729,7 +727,7 @@ let ensure_list global list_mono _loc bt = | None -> fail "ensure_list: not a monomorphised list" (BT.pp bt) in let dt_sym = Option.get (BT.is_datatype_bt dt_bt) in - let dt_info = SymMap.find dt_sym global.Global.datatypes in + let dt_info = Sym.Map.find dt_sym global.Global.datatypes in let nil_nm, cons_nm = match dt_info.constrs with [ nil; cons ] -> (nil, cons) | _ -> assert false in @@ -782,7 +780,7 @@ let ensure_tuple_op is_upd nm (ix, l) = let ensure_pred global list_mono loc name aux = let open LogicalFunctions in - let def = SymMap.find name global.Global.logical_functions in + let def = Sym.Map.find name global.Global.logical_functions in let inf = (loc, Pp.typ (Pp.string "pred") (Sym.pp name)) in match def.definition with | Uninterp -> @@ -1094,7 +1092,7 @@ let it_to_coq loc global list_mono it = let@ op_nm = ensure_struct_mem true global list_mono loc ct aux in parensM (build [ rets op_nm; aux t2 ]) | IT.Constructor (nm, id_args) -> - let info = SymMap.find nm global.datatype_constrs in + let info = Sym.Map.find nm global.datatype_constrs in let comp = Some (t, "datatype contents") in let@ () = ensure_datatype global list_mono loc info.datatype_tag in (* assuming here that the id's are in canonical order *) @@ -1330,9 +1328,9 @@ let do_re_retype mu_file trusted_funs prev_mode pred_defs pre_retype_mu_file = | `CallByReference -> let prev_cut = let open Retype.Old in - let info2 = Pmap.filter (fun fsym _ -> SymSet.mem fsym trusted_funs) + let info2 = Pmap.filter (fun fsym _ -> Sym.Set.mem fsym trusted_funs) pre_retype_mu_file.mu_funinfo in - let funs2 = Pmap.filter (fun fsym _ -> SymSet.mem fsym trusted_funs) + let funs2 = Pmap.filter (fun fsym _ -> Sym.Set.mem fsym trusted_funs) pre_retype_mu_file.mu_funs in { pre_retype_mu_file with mu_funs = funs2; mu_funinfo = info2 } in @@ -1372,8 +1370,8 @@ let generate (global : Global.t) directions (lemmata : (Sym.t * (Loc.t * AT.lemm "skipping trusted fun with resource" (Sym.pp_string x.sym ^ ": " ^ Option.get x.scan_res.res)) skip; - (* let fun_info = List.fold_right (fun (s, def) m -> SymMap.add s def m) *) - (* mu_file.mu_logical_predicates SymMap.empty in *) + (* let fun_info = List.fold_right (fun (s, def) m -> Sym.Map.add s def m) *) + (* mu_file.mu_logical_predicates Sym.Map.empty in *) (* let struct_decls = get_struct_decls mu_file in *) (* let global = Global.{ctxt.Context.global with struct_decls} in *) let list_mono, global = monomorphise_dt_lists global in diff --git a/backend/cn/lib/logicalArgumentTypes.ml b/backend/cn/lib/logicalArgumentTypes.ml index c634fa4c5..911e3b198 100644 --- a/backend/cn/lib/logicalArgumentTypes.ml +++ b/backend/cn/lib/logicalArgumentTypes.ml @@ -4,8 +4,6 @@ module IT = IndexTerms module LS = LogicalSorts module RET = ResourceTypes module LC = LogicalConstraints -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) type 'i t = | Define of (Sym.t * IT.t) * info * 'i t @@ -54,7 +52,7 @@ and alpha_rename i_subst s t = and suitably_alpha_rename i_subst syms s t = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename i_subst s t else (s, t) @@ -62,18 +60,18 @@ and suitably_alpha_rename i_subst syms s t = let free_vars_bts i_free_vars_bts = let union = - SymMap.union (fun _ bt1 bt2 -> + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) in let rec aux = function | Define ((s, it), _info, t) -> let it_vars = IT.free_vars_bts it in - let t_vars = SymMap.remove s (aux t) in + let t_vars = Sym.Map.remove s (aux t) in union it_vars t_vars | Resource ((s, (re, _bt)), _info, t) -> let re_vars = RET.free_vars_bts re in - let t_vars = SymMap.remove s (aux t) in + let t_vars = Sym.Map.remove s (aux t) in union re_vars t_vars | Constraint (lc, _info, t) -> let lc_vars = LC.free_vars_bts lc in @@ -88,16 +86,16 @@ let free_vars i_free_vars = let rec aux = function | Define ((s, it), _info, t) -> let it_vars = IT.free_vars it in - let t_vars = SymSet.remove s (aux t) in - SymSet.union it_vars t_vars + let t_vars = Sym.Set.remove s (aux t) in + Sym.Set.union it_vars t_vars | Resource ((s, (re, _bt)), _info, t) -> let re_vars = RET.free_vars re in - let t_vars = SymSet.remove s (aux t) in - SymSet.union re_vars t_vars + let t_vars = Sym.Set.remove s (aux t) in + Sym.Set.union re_vars t_vars | Constraint (lc, _info, t) -> let lc_vars = LC.free_vars lc in let t_vars = aux t in - SymSet.union lc_vars t_vars + Sym.Set.union lc_vars t_vars | I i -> i_free_vars i in aux @@ -154,11 +152,11 @@ let alpha_unique ss = match at with | Define ((name, it), info, t) -> let name, t = rename_if ss name t in - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in Define ((name, it), info, t) | Resource ((name, (re, bt)), info, t) -> let name, t = rename_if ss name t in - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in Resource ((name, (re, bt)), info, f ss t) | Constraint (lc, info, t) -> Constraint (lc, info, f ss t) | I i -> I (RT.alpha_unique ss i) diff --git a/backend/cn/lib/logicalConstraints.ml b/backend/cn/lib/logicalConstraints.ml index a979399a4..99bd54df5 100644 --- a/backend/cn/lib/logicalConstraints.ml +++ b/backend/cn/lib/logicalConstraints.ml @@ -1,7 +1,5 @@ module IT = IndexTerms module BT = BaseTypes -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) open Pp type logical_constraint = @@ -34,12 +32,12 @@ let subst_ su c = subst (IT.make_subst su) c let free_vars_bts = function | T c -> IT.free_vars_bts c - | Forall ((s, _), body) -> SymMap.remove s (IT.free_vars_bts body) + | Forall ((s, _), body) -> Sym.Map.remove s (IT.free_vars_bts body) let free_vars = function | T c -> IT.free_vars c - | Forall ((s, _), body) -> SymSet.remove s (IT.free_vars body) + | Forall ((s, _), body) -> Sym.Set.remove s (IT.free_vars body) let alpha_equivalent lc lc' = diff --git a/backend/cn/lib/logicalFunctions.ml b/backend/cn/lib/logicalFunctions.ml index 38751c045..ce878d03f 100644 --- a/backend/cn/lib/logicalFunctions.ml +++ b/backend/cn/lib/logicalFunctions.ml @@ -4,8 +4,6 @@ module BT = BaseTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes open IndexTerms -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) type def_or_uninterp = | Def of IT.t @@ -78,32 +76,32 @@ let try_open_fun def args = def.return_bt body ) (try_open_fun def name args) *) (* let add_unfolds_to_terms preds terms = let rec f acc t = match IT.term t with | - IT.Apply (name, ts) -> let def = SymMap.find name preds in begin match + IT.Apply (name, ts) -> let def = Sym.Map.find name preds in begin match try_open_fun_to_term def name ts with | None -> acc | Some t2 -> f (t2 :: acc) t2 end | _ -> acc in IT.fold_list (fun _ acc t -> f acc t) [] terms terms *) (* (\* Check for cycles in the logical predicate graph, which would cause *) (* the system to loop trying to unfold them. Predicates whose definition *) (* are marked with Rec_Def aren't checked, as cycles there are expected. *\) *) -(* let cycle_check (defs : definition SymMap.t) = *) +(* let cycle_check (defs : definition Sym.Map.t) = *) (* let def_preds nm = *) -(* let def = SymMap.find nm defs in *) +(* let def = Sym.Map.find nm defs in *) (* begin match def.definition with *) -(* | Def t -> SymSet.elements (IT.preds_of (Body.to_term def.return_bt t)) *) +(* | Def t -> Sym.Set.elements (IT.preds_of (Body.to_term def.return_bt t)) *) (* | _ -> [] *) (* end *) (* in *) (* let rec search known_ok = function *) (* | [] -> None *) -(* | (nm, Some path) :: q -> if SymSet.mem nm known_ok *) +(* | (nm, Some path) :: q -> if Sym.Set.mem nm known_ok *) (* then search known_ok q *) (* else if List.exists (Sym.equal nm) path *) (* then Some (List.rev path @ [nm]) *) (* else *) (* let deps = List.map (fun p -> (p, Some (nm :: path))) (def_preds nm) in *) (* search known_ok (deps @ [(nm, None)] @ q) *) -(* | (nm, None) :: q -> search (SymSet.add nm known_ok) q *) -(* in search SymSet.empty (List.map (fun (p, _) -> (p, Some [])) (SymMap.bindings +(* | (nm, None) :: q -> search (Sym.Set.add nm known_ok) q *) +(* in search Sym.Set.empty (List.map (fun (p, _) -> (p, Some [])) (Sym.Map.bindings defs)) *) (*Extensibility hook. For now, all functions are displayed as "interesting" in error reporting*) diff --git a/backend/cn/lib/logicalReturnTypes.ml b/backend/cn/lib/logicalReturnTypes.ml index f305a14ba..631a44be0 100644 --- a/backend/cn/lib/logicalReturnTypes.ml +++ b/backend/cn/lib/logicalReturnTypes.ml @@ -1,5 +1,4 @@ open Locations -module SymSet = Set.Make (Sym) module BT = BaseTypes module RT = ResourceTypes module IT = IndexTerms @@ -55,27 +54,27 @@ and alpha_rename from t = and suitably_alpha_rename syms s t = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename s t else (s, t) let rec bound = function - | Define ((s, _), _, lrt) -> SymSet.add s (bound lrt) - | Resource ((s, _), _, lrt) -> SymSet.add s (bound lrt) + | Define ((s, _), _, lrt) -> Sym.Set.add s (bound lrt) + | Resource ((s, _), _, lrt) -> Sym.Set.add s (bound lrt) | Constraint (_, _, lrt) -> bound lrt - | I -> SymSet.empty + | I -> Sym.Set.empty let alpha_unique ss = let rec f ss = function | Resource ((name, (re, bt)), info, t) -> - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in let name, t = suitably_alpha_rename ss name t in Resource ((name, (re, bt)), info, t) | Define ((name, it), info, t) -> - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in let name, t = suitably_alpha_rename ss name t in Define ((name, it), info, t) | Constraint (lc, info, t) -> Constraint (lc, info, f ss t) @@ -100,11 +99,11 @@ let binders = let free_vars lrt = let rec f = function - | Define ((nm, it), _, t) -> SymSet.union (IT.free_vars it) (SymSet.remove nm (f t)) + | Define ((nm, it), _, t) -> Sym.Set.union (IT.free_vars it) (Sym.Set.remove nm (f t)) | Resource ((nm, (re, _)), _, t) -> - SymSet.union (RT.free_vars re) (SymSet.remove nm (f t)) - | Constraint (lc, _, t) -> SymSet.union (LogicalConstraints.free_vars lc) (f t) - | I -> SymSet.empty + Sym.Set.union (RT.free_vars re) (Sym.Set.remove nm (f t)) + | Constraint (lc, _, t) -> Sym.Set.union (LogicalConstraints.free_vars lc) (f t) + | I -> Sym.Set.empty in f lrt diff --git a/backend/cn/lib/logicalSorts.ml b/backend/cn/lib/logicalSorts.ml index da77f5c88..854fe4681 100644 --- a/backend/cn/lib/logicalSorts.ml +++ b/backend/cn/lib/logicalSorts.ml @@ -1,5 +1,4 @@ module Loc = Locations -module SymSet = Set.Make (Sym) type t = BaseTypes.t diff --git a/backend/cn/lib/memory.ml b/backend/cn/lib/memory.ml index 373a0bf09..785df6cfd 100644 --- a/backend/cn/lib/memory.ml +++ b/backend/cn/lib/memory.ml @@ -1,6 +1,5 @@ module CF = Cerb_frontend module BT = BaseTypes -module SymMap = Map.Make (Sym) module IM = struct include CF.Impl_mem @@ -80,7 +79,7 @@ type struct_layout = struct_piece list type struct_decl = struct_layout -type struct_decls = struct_layout SymMap.t +type struct_decls = struct_layout Sym.Map.t let members = List.filter_map (fun { member_or_padding; _ } -> Option.map fst member_or_padding) diff --git a/backend/cn/lib/mucore.ml b/backend/cn/lib/mucore.ml index f83dd86cc..e35bf48b9 100644 --- a/backend/cn/lib/mucore.ml +++ b/backend/cn/lib/mucore.ml @@ -427,7 +427,7 @@ type 'TY file = globs : (Sym.t * 'TY globs) list; funs : (Sym.t, 'TY fun_map_decl) Pmap.map; extern : Cerb_frontend.Core.extern_map; - stdlib_syms : Set.Make(Sym).t; + stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; resource_predicates : (Sym.t * ResourcePredicates.definition) list; logical_predicates : (Sym.t * LogicalFunctions.definition) list; @@ -442,9 +442,7 @@ let empty_file : 'TY file = globs = []; funs = Pmap.empty Sym.compare; extern = Pmap.empty Id.compare; - stdlib_syms = - (let open Set.Make (Sym) in - empty); + stdlib_syms = Sym.Set.empty; mk_functions = []; resource_predicates = []; logical_predicates = []; diff --git a/backend/cn/lib/mucore.mli b/backend/cn/lib/mucore.mli index c8567b750..ca77f4a49 100644 --- a/backend/cn/lib/mucore.mli +++ b/backend/cn/lib/mucore.mli @@ -330,7 +330,7 @@ type 'TY file = globs : (Sym.t * 'TY globs) list; funs : (Sym.t, 'TY fun_map_decl) Pmap.map; extern : Cerb_frontend.Core.extern_map; - stdlib_syms : Set.Make(Sym).t; + stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; resource_predicates : (Sym.t * ResourcePredicates.definition) list; logical_predicates : (Sym.t * LogicalFunctions.definition) list; diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index 3b4536192..db7e7e623 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -46,7 +46,7 @@ let packing_ft loc global provable ret = let at = LAT.Resource ((o_s, (qpred, IT.bt o)), (loc, None), LAT.I o) in Some at | Owned (Struct tag, init) -> - let layout = SymMap.find tag global.Global.struct_decls in + let layout = Sym.Map.find tag global.Global.struct_decls in let lrt, value = List.fold_right (fun { offset; size; member_or_padding } (lrt, value) -> @@ -84,7 +84,7 @@ let packing_ft loc global provable ret = let at = LAT.of_lrt lrt (LAT.I (struct_ (tag, value) loc)) in Some at | PName pn -> - let def = SymMap.find pn global.resource_predicates in + let def = Sym.Map.find pn global.resource_predicates in (match identify_right_clause provable def ret.pointer ret.iargs with | None -> None | Some right_clause -> Some right_clause.packing_ft)) @@ -97,7 +97,7 @@ let unpack_owned loc global (ct, init) pointer (O o) = | Void | Integer _ | Pointer _ | Function _ -> None | Array (ict, olength) -> Some [ (unfolded_array loc init (ict, olength) pointer, O o) ] | Struct tag -> - let layout = SymMap.find tag global.Global.struct_decls in + let layout = Sym.Map.find tag global.Global.struct_decls in let res = List.fold_right (fun { offset; size; member_or_padding } res -> diff --git a/backend/cn/lib/resourceTypes.ml b/backend/cn/lib/resourceTypes.ml index 3291b6f5c..ae98ba361 100644 --- a/backend/cn/lib/resourceTypes.ml +++ b/backend/cn/lib/resourceTypes.ml @@ -1,7 +1,5 @@ open Pp.Infix module IT = IndexTerms -module SymSet = IT.SymSet -module SymMap = IT.SymMap module LCSet = Set.Make (LogicalConstraints) type init = @@ -121,7 +119,7 @@ let subst_predicate_type substitution (p : predicate_type) = let subst_qpredicate_type substitution (qp : qpredicate_type) = let qp = - if SymSet.mem (fst qp.q) substitution.Subst.relevant then + if Sym.Set.mem (fst qp.q) substitution.Subst.relevant then alpha_rename_qpredicate_type qp else qp @@ -144,20 +142,20 @@ let subst (substitution : _ Subst.t) = function let free_vars_bts = function | P p -> IT.free_vars_bts_list (p.pointer :: p.iargs) | Q p -> - SymMap.union + Sym.Map.union (fun _ bt1 bt2 -> assert (BaseTypes.equal bt1 bt2); Some bt1) (IT.free_vars_bts_list [ p.pointer; p.step ]) - (SymMap.remove (fst p.q) (IT.free_vars_bts_list (p.permission :: p.iargs))) + (Sym.Map.remove (fst p.q) (IT.free_vars_bts_list (p.permission :: p.iargs))) let free_vars = function | P p -> IT.free_vars_list (p.pointer :: p.iargs) | Q p -> - SymSet.union - (SymSet.union (IT.free_vars p.pointer) (IT.free_vars p.step)) - (SymSet.remove (fst p.q) (IT.free_vars_list (p.permission :: p.iargs))) + Sym.Set.union + (Sym.Set.union (IT.free_vars p.pointer) (IT.free_vars p.step)) + (Sym.Set.remove (fst p.q) (IT.free_vars_list (p.permission :: p.iargs))) (* resources of the same type as a request, such that the resource coult potentially be diff --git a/backend/cn/lib/resourceTypes.mli b/backend/cn/lib/resourceTypes.mli index e72cb6893..e3cea8ab7 100644 --- a/backend/cn/lib/resourceTypes.mli +++ b/backend/cn/lib/resourceTypes.mli @@ -64,9 +64,9 @@ val subst resource_type -> resource_type -val free_vars_bts : resource_type -> BaseTypes.t IndexTerms.SymMap.t +val free_vars_bts : resource_type -> BaseTypes.t Sym.Map.t -val free_vars : resource_type -> IndexTerms.SymSet.t +val free_vars : resource_type -> Sym.Set.t val same_predicate_name : resource_type -> resource_type -> bool diff --git a/backend/cn/lib/resources.ml b/backend/cn/lib/resources.ml index 72213bc7c..9d45ea9e2 100644 --- a/backend/cn/lib/resources.ml +++ b/backend/cn/lib/resources.ml @@ -1,6 +1,4 @@ module CF = Cerb_frontend -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module IT = IndexTerms module LC = LogicalConstraints module LCSet = Set.Make (LC) @@ -26,7 +24,9 @@ let subst substitution ((r, O oargs) : t) = (ResourceTypes.subst substitution r, O (IT.subst substitution oargs)) -let free_vars (r, O oargs) = SymSet.union (ResourceTypes.free_vars r) (IT.free_vars oargs) +let free_vars (r, O oargs) = + Sym.Set.union (ResourceTypes.free_vars r) (IT.free_vars oargs) + let range_size ct = let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in diff --git a/backend/cn/lib/returnTypes.ml b/backend/cn/lib/returnTypes.ml index e653df197..967ba3adc 100644 --- a/backend/cn/lib/returnTypes.ml +++ b/backend/cn/lib/returnTypes.ml @@ -1,5 +1,4 @@ open Locations -module SymSet = Set.Make (Sym) module IT = IndexTerms module LRT = LogicalReturnTypes @@ -22,7 +21,7 @@ and alpha_rename from t = and suitably_alpha_rename syms s t = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename s t else (s, t) @@ -30,7 +29,7 @@ and suitably_alpha_rename syms s t = let alpha_unique ss = function | Computational ((name, bt), oinfo, t) -> - let t = LRT.alpha_unique (SymSet.add name ss) t in + let t = LRT.alpha_unique (Sym.Set.add name ss) t in let name, t = LRT.suitably_alpha_rename ss name t in Computational ((name, bt), oinfo, t) @@ -51,7 +50,7 @@ let map (f : LRT.t -> LRT.t) = function | Computational (param, oinfo, t) -> Computational (param, oinfo, f t) -let bound = function Computational ((s, _), _, lrt) -> SymSet.add s (LRT.bound lrt) +let bound = function Computational ((s, _), _, lrt) -> Sym.Set.add s (LRT.bound lrt) let pp_aux rt = let open Pp in diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index 4640bedd3..56ac5de22 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -19,11 +19,11 @@ module LCSet = Set.Make (LC) type simp_ctxt = { global : Global.t; - values : IT.t SymMap.t; + values : IT.t Sym.Map.t; simp_hook : IT.t -> IT.t option } -let default global = { global; values = SymMap.empty; simp_hook = (fun _ -> None) } +let default global = { global; values = Sym.Map.empty; simp_hook = (fun _ -> None) } let do_ctz_z z = let rec loop z found = @@ -207,7 +207,7 @@ module IndexTerms = struct match the_term_ with | Sym _ when BT.equal the_bt BT.Unit -> unit_ the_loc | Sym sym -> - (match SymMap.find_opt sym simp_ctxt.values with + (match Sym.Map.find_opt sym simp_ctxt.values with | Some (IT ((Const _ | Sym _), _, _) as v) -> v | _ -> the_term) | Const _ -> the_term @@ -597,7 +597,7 @@ module IndexTerms = struct if not inline_functions then t else ( - let def = SymMap.find name simp_ctxt.global.logical_functions in + let def = Sym.Map.find name simp_ctxt.global.logical_functions in match LogicalFunctions.try_open_fun def args with | Some inlined -> aux inlined | None -> t) diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 0510254b2..a5623f778 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -5,8 +5,6 @@ module BT = BaseTypes open BaseTypes module LC = LogicalConstraints open LogicalConstraints -module SymMap = Map.Make (Sym) -module SymSet = Set.Make (Sym) module Int_BT_Table = Map.Make (struct type t = int * BT.t @@ -76,7 +74,7 @@ end type solver_frame = { mutable commands : SMT.sexp list; (** Ack-style SMT commands, most recent first. *) - mutable uninterpreted : SMT.sexp SymMap.t; + mutable uninterpreted : SMT.sexp Sym.Map.t; (** Uninterpreted functions and variables that we've declared. *) mutable bt_uninterpreted : SMT.sexp Int_BT_Table.t; (** Uninterpreted constants, indexed by base type. *) @@ -86,7 +84,7 @@ type solver_frame = let empty_solver_frame () = { commands = []; - uninterpreted = SymMap.empty; + uninterpreted = Sym.Map.empty; bt_uninterpreted = Int_BT_Table.empty; ctypes = CTypeMap.empty } @@ -114,7 +112,7 @@ module Debug = struct rest ^/^ bar ^^^ BT.pp k ^^^ !^"|->" ^^^ !^(to_string v) in !^"# Symbols" - |> SymMap.fold dump_sym f.uninterpreted + |> Sym.Map.fold dump_sym f.uninterpreted |> append "# Basetypes " |> Int_BT_Table.fold dump_bts f.bt_uninterpreted |> append "+---------------------------------" @@ -209,7 +207,7 @@ let fresh_name s x = (** Declare an uninterpreted function. *) let declare_uninterpreted s name args_ts res_t = - let check f = SymMap.find_opt name f.uninterpreted in + let check f = Sym.Map.find_opt name f.uninterpreted in match search_frames s check with | Some e -> e | None -> @@ -217,7 +215,7 @@ let declare_uninterpreted s name args_ts res_t = ack_command s (SMT.declare_fun sname args_ts res_t); let e = SMT.atom sname in let f = !(s.cur_frame) in - f.uninterpreted <- SymMap.add name e f.uninterpreted; + f.uninterpreted <- Sym.Map.add name e f.uninterpreted; e @@ -564,15 +562,15 @@ and get_value gs ctys bt (sexp : SMT.sexp) = Tuple (List.map2 (get_ivalue gs ctys) bts vals) | Struct tag -> let _con, vals = SMT.to_con sexp in - let decl = SymMap.find tag gs.struct_decls in + let decl = Sym.Map.find tag gs.struct_decls in let fields = List.filter_map (fun x -> x.Memory.member_or_padding) decl in let mk_field (l, t) v = (l, get_ivalue gs ctys (Memory.bt_of_sct t) v) in Struct (tag, List.map2 mk_field fields vals) | Datatype tag -> let con, vals = SMT.to_con sexp in - let cons = (SymMap.find tag gs.datatypes).constrs in + let cons = (Sym.Map.find tag gs.datatypes).constrs in let do_con c = - let fields = (SymMap.find c gs.datatype_constrs).params in + let fields = (Sym.Map.find c gs.datatype_constrs).params in let mk_field (l, t) v = (l, get_ivalue gs ctys t v) in Constructor (c, List.map2 mk_field fields vals) in @@ -675,7 +673,7 @@ let bv_ctz result_w = (** Translate a variable to SMT. Declare if needed. *) let translate_var s name bt = - let check f = SymMap.find_opt name f.uninterpreted in + let check f = Sym.Map.find_opt name f.uninterpreted in match search_frames s check with | Some e -> e | None -> @@ -683,7 +681,7 @@ let translate_var s name bt = ack_command s (SMT.declare sname (translate_base_type bt)); let e = SMT.atom sname in let f = !(s.cur_frame) in - f.uninterpreted <- SymMap.add name e f.uninterpreted; + f.uninterpreted <- Sym.Map.add name e f.uninterpreted; e @@ -891,7 +889,7 @@ let rec translate_term s iterm = SMT.app_ (CN_Names.struct_field_name f) [ translate_term s e1 ] | StructUpdate ((t, member), v) -> let tag = BT.struct_bt (IT.bt t) in - let layout = SymMap.find (struct_bt (IT.bt t)) struct_decls in + let layout = Sym.Map.find (struct_bt (IT.bt t)) struct_decls in let members = Memory.member_types layout in let str = List.map @@ -907,7 +905,7 @@ let rec translate_term s iterm = in translate_term s (struct_ (tag, str) loc) | OffsetOf (tag, member) -> - let decl = SymMap.find tag struct_decls in + let decl = Sym.Map.find tag struct_decls in let v = Option.get (Memory.member_offset decl member) in translate_term s (int_lit_ v (IT.basetype iterm) loc) (* Records *) @@ -1145,12 +1143,12 @@ let shortcut simp_ctxt lc = let declare_datatype_group s names = let mk_con_field (l, t) = (CN_Names.datatype_field_name l, translate_base_type t) in let mk_con c = - let ci = SymMap.find c s.globals.datatype_constrs in + let ci = Sym.Map.find c s.globals.datatype_constrs in (CN_Names.datatype_con_name c, List.map mk_con_field ci.params) in let cons (info : BT.dt_info) = List.map mk_con info.constrs in let to_smt (x : Sym.t) = - let info = SymMap.find x s.globals.datatypes in + let info = Sym.Map.find x s.globals.datatypes in (CN_Names.datatype_name x, [], cons info) in ack_command s (SMT.declare_datatypes (List.map to_smt names)) @@ -1160,15 +1158,15 @@ let declare_datatype_group s names = The `done_struct` keeps track of which structs we've already declared. *) let rec declare_struct s done_struct name decl = let mp = !done_struct in - if SymSet.mem name mp then + if Sym.Set.mem name mp then () else ( - done_struct := SymSet.add name mp; + done_struct := Sym.Set.add name mp; let mk_field (l, t) = let rec declare_nested ty = match ty with | Struct name' -> - let decl = SymMap.find name' s.globals.struct_decls in + let decl = Sym.Map.find name' s.globals.struct_decls in declare_struct s done_struct name' decl | Map (_, el) -> declare_nested el | _ -> () @@ -1196,8 +1194,8 @@ let declare_solver_basics s = CN_Pointer.declare s; (* structs may depend only on other structs. datatypes may depend on other datatypes and structs. *) - let done_structs = ref SymSet.empty in - SymMap.iter (declare_struct s done_structs) s.globals.struct_decls; + let done_structs = ref Sym.Set.empty in + Sym.Map.iter (declare_struct s done_structs) s.globals.struct_decls; List.iter (declare_datatype_group s) (Option.get s.globals.datatype_order) diff --git a/backend/cn/lib/subst.ml b/backend/cn/lib/subst.ml index c44755945..273ddcf8b 100644 --- a/backend/cn/lib/subst.ml +++ b/backend/cn/lib/subst.ml @@ -1,10 +1,9 @@ -module SymSet = Set.Make (Sym) open Pp type 'a t = { replace : (Sym.t * 'a) list; - relevant : SymSet.t; - flags : SymSet.t + relevant : Sym.Set.t; + flags : Sym.Set.t } type 'a subst = 'a t @@ -18,15 +17,15 @@ let pp ppf subst = let make free_vars replace = let relevant = List.fold_right - (fun (s, r) acc -> SymSet.union (free_vars r) (SymSet.add s acc)) + (fun (s, r) acc -> Sym.Set.union (free_vars r) (Sym.Set.add s acc)) replace - SymSet.empty + Sym.Set.empty in - { replace; relevant; flags = SymSet.empty } + { replace; relevant; flags = Sym.Set.empty } let add free_vars (s, r) subst = { subst with replace = (s, r) :: subst.replace; - relevant = SymSet.union (free_vars r) (SymSet.add s subst.relevant) + relevant = Sym.Set.union (free_vars r) (Sym.Set.add s subst.relevant) } diff --git a/backend/cn/lib/sym.ml b/backend/cn/lib/sym.ml index 182b3b3fe..d7eda8b10 100644 --- a/backend/cn/lib/sym.ml +++ b/backend/cn/lib/sym.ml @@ -4,13 +4,20 @@ include S let executable_spec_enabled = ref false -type t = S.sym +module Ord = struct + type t = S.sym + + let compare = S.symbol_compare +end + +include Ord type sym = t let equal = S.symbolEquality -let compare = S.symbol_compare +module Set = Set.Make (Ord) +module Map = Map.Make (Ord) type description = S.symbol_description diff --git a/backend/cn/lib/testGeneration/genAnalysis.ml b/backend/cn/lib/testGeneration/genAnalysis.ml index bb6d7389d..19d04a2b1 100644 --- a/backend/cn/lib/testGeneration/genAnalysis.ml +++ b/backend/cn/lib/testGeneration/genAnalysis.ml @@ -7,8 +7,6 @@ module RP = ResourcePredicates module LAT = LogicalArgumentTypes module GT = GenTerms module GD = GenDefinitions -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) let rec is_pure (gt : GT.t) : bool = let (GT (gt_, _, _)) = gt in @@ -25,9 +23,9 @@ let rec is_pure (gt : GT.t) : bool = | Map _ -> false -let get_single_uses ?(pure : bool = false) (gt : GT.t) : SymSet.t = +let get_single_uses ?(pure : bool = false) (gt : GT.t) : Sym.Set.t = let union = - SymMap.union (fun _ oa ob -> + Sym.Map.union (fun _ oa ob -> Some (let open Option in let@ a = oa in @@ -35,46 +33,46 @@ let get_single_uses ?(pure : bool = false) (gt : GT.t) : SymSet.t = return (a + b))) in let it_value : int option = if pure then Some 1 else None in - let aux_it (it : IT.t) : int option SymMap.t = + let aux_it (it : IT.t) : int option Sym.Map.t = it |> IT.free_vars - |> SymSet.to_seq + |> Sym.Set.to_seq |> Seq.map (fun x -> (x, it_value)) - |> SymMap.of_seq + |> Sym.Map.of_seq in - let aux_lc (lc : LC.t) : int option SymMap.t = + let aux_lc (lc : LC.t) : int option Sym.Map.t = lc |> LC.free_vars - |> SymSet.to_seq + |> Sym.Set.to_seq |> Seq.map (fun x -> (x, it_value)) - |> SymMap.of_seq + |> Sym.Map.of_seq in - let rec aux (gt : GT.t) : int option SymMap.t = + let rec aux (gt : GT.t) : int option Sym.Map.t = let (GT (gt_, _, _)) = gt in match gt_ with - | Arbitrary | Uniform _ -> SymMap.empty + | Arbitrary | Uniform _ -> Sym.Map.empty | Pick wgts -> - wgts |> List.map snd |> List.map aux |> List.fold_left union SymMap.empty + wgts |> List.map snd |> List.map aux |> List.fold_left union Sym.Map.empty | Alloc it | Return it -> aux_it it | Call (_, iargs) -> - iargs |> List.map snd |> List.map aux_it |> List.fold_left union SymMap.empty + iargs |> List.map snd |> List.map aux_it |> List.fold_left union Sym.Map.empty | Asgn ((it_addr, _), it_val, gt') -> - aux gt' :: List.map aux_it [ it_addr; it_val ] |> List.fold_left union SymMap.empty - | Let (_, (x, gt1), gt2) -> SymMap.remove x (union (aux gt1) (aux gt2)) + aux gt' :: List.map aux_it [ it_addr; it_val ] |> List.fold_left union Sym.Map.empty + | Let (_, (x, gt1), gt2) -> Sym.Map.remove x (union (aux gt1) (aux gt2)) | Assert (lc, gt') -> union (aux gt') (aux_lc lc) | ITE (it_if, gt_then, gt_else) -> aux_it it_if :: List.map aux [ gt_then; gt_else ] - |> List.fold_left union SymMap.empty + |> List.fold_left union Sym.Map.empty | Map ((i, _, it_perm), gt') -> union (aux_it it_perm) - (gt' |> aux |> SymMap.remove i |> SymMap.map (Option.map (Int.add 1))) + (gt' |> aux |> Sym.Map.remove i |> Sym.Map.map (Option.map (Int.add 1))) in aux gt - |> SymMap.filter (fun _ -> Option.equal Int.equal (Some 1)) - |> SymMap.bindings + |> Sym.Map.filter (fun _ -> Option.equal Int.equal (Some 1)) + |> Sym.Map.bindings |> List.map fst - |> SymSet.of_list + |> Sym.Set.of_list module Bounds = struct @@ -152,8 +150,8 @@ end let get_bounds = Bounds.get_bounds -let get_recursive_preds (preds : (Sym.t * RP.definition) list) : SymSet.t = - let get_calls (pred : RP.definition) : SymSet.t = +let get_recursive_preds (preds : (Sym.t * RP.definition) list) : Sym.Set.t = + let get_calls (pred : RP.definition) : Sym.Set.t = pred.clauses |> Option.get |> List.map (fun (cl : RP.clause) -> cl.packing_ft) @@ -164,13 +162,13 @@ let get_recursive_preds (preds : (Sym.t * RP.definition) list) : SymSet.t = |> List.map ResourceTypes.predicate_name |> List.filter_map (fun (n : RET.predicate_name) -> match n with PName name -> Some name | Owned _ -> None) - |> SymSet.of_list + |> Sym.Set.of_list in let module G = Graph.Persistent.Digraph.Concrete (Sym) in let g = List.fold_left (fun g (fsym, pred) -> - SymSet.fold (fun gsym g' -> G.add_edge g' fsym gsym) (get_calls pred) g) + Sym.Set.fold (fun gsym g' -> G.add_edge g' fsym gsym) (get_calls pred) g) G.empty preds in @@ -179,22 +177,22 @@ let get_recursive_preds (preds : (Sym.t * RP.definition) list) : SymSet.t = preds |> List.map fst |> List.filter (fun fsym -> G.mem_edge closure fsym fsym) - |> SymSet.of_list + |> Sym.Set.of_list module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) open struct - let get_calls (gd : GD.t) : SymSet.t = - let rec aux (gt : GT.t) : SymSet.t = + let get_calls (gd : GD.t) : Sym.Set.t = + let rec aux (gt : GT.t) : Sym.Set.t = let (GT (gt_, _, _)) = gt in match gt_ with - | Arbitrary | Uniform _ | Alloc _ | Return _ -> SymSet.empty + | Arbitrary | Uniform _ | Alloc _ | Return _ -> Sym.Set.empty | Pick wgts -> - wgts |> List.map snd |> List.map aux |> List.fold_left SymSet.union SymSet.empty - | Call (fsym, _) -> SymSet.singleton fsym + wgts |> List.map snd |> List.map aux |> List.fold_left Sym.Set.union Sym.Set.empty + | Call (fsym, _) -> Sym.Set.singleton fsym | Asgn (_, _, gt') | Assert (_, gt') | Map (_, gt') -> aux gt' - | Let (_, (_, gt1), gt2) | ITE (_, gt1, gt2) -> SymSet.union (aux gt1) (aux gt2) + | Let (_, (_, gt1), gt2) | ITE (_, gt1, gt2) -> Sym.Set.union (aux gt1) (aux gt2) in aux (Option.get gd.body) @@ -210,6 +208,6 @@ let get_call_graph (ctx : GD.context) : SymGraph.t = |> List.map_snd get_calls |> List.fold_left (fun cg (fsym, calls) -> - SymSet.fold (fun fsym' cg' -> SymGraph.add_edge cg' fsym fsym') calls cg) + Sym.Set.fold (fun fsym' cg' -> SymGraph.add_edge cg' fsym fsym') calls cg) SymGraph.empty |> Oper.transitive_closure diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index 278effae0..37ffb16d5 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -8,7 +8,6 @@ module IT = IndexTerms module LC = LogicalConstraints module GT = GenTerms module GR = GenRuntime -module SymSet = Set.Make (Sym) let mk_expr = Utils.mk_expr @@ -203,12 +202,12 @@ let rec compile_term macro_call "CN_GEN_CALL_TO" to_vars ]) @ - if GR.SymSet.is_empty path_vars then + if Sym.Set.is_empty path_vars then [] else [ macro_call "CN_GEN_CALL_PATH_VARS" - (path_vars |> GR.SymSet.to_seq |> List.of_seq |> List.map wrap_to_string) + (path_vars |> Sym.Set.to_seq |> List.of_seq |> List.map wrap_to_string) ]), mk_expr (AilEident x) ) | Asgn { pointer; addr; sct; value; last_var; rest } -> @@ -253,7 +252,7 @@ let rec compile_term ( None, [ (Locations.other __LOC__, [ Sym.pp_string x ]) ] )) ))) - (List.of_seq (SymSet.to_seq (IT.free_vars addr))) + (List.of_seq (Sym.Set.to_seq (IT.free_vars addr))) @ [ mk_expr (AilEconst ConstantNull) ] ))) ] in @@ -329,7 +328,7 @@ let rec compile_term ( None, [ (Locations.other __LOC__, [ Sym.pp_string x ]) ] )) ))) - (List.of_seq (GR.SymSet.to_seq (GR.free_vars_term value))) + (List.of_seq (Sym.Set.to_seq (GR.free_vars_term value))) @ [ mk_expr (AilEconst ConstantNull) ] ))) ]) in @@ -359,7 +358,7 @@ let rec compile_term ( None, [ (Locations.other __LOC__, [ Sym.pp_string x ]) ] )) ))) - (List.of_seq (SymSet.to_seq (LC.free_vars prop))) + (List.of_seq (Sym.Set.to_seq (LC.free_vars prop))) @ [ mk_expr (AilEconst ConstantNull) ] ))) ] in @@ -424,7 +423,7 @@ let rec compile_term [ (Locations.other __LOC__, [ Sym.pp_string x ]) ] )) ))) (List.of_seq - (SymSet.to_seq (SymSet.remove i (IT.free_vars perm)))) + (Sym.Set.to_seq (Sym.Set.remove i (IT.free_vars perm)))) @ [ mk_expr (AilEconst ConstantNull) ] ))) ]) in @@ -457,7 +456,7 @@ let rec compile_term let e_ty = mk_expr (AilEident (Sym.fresh_named (name_of_bt name Memory.size_bt))) in let e_tmp = mk_expr (AilEident marker_var) in let e_size = mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")) in - let syms_l = syms |> GR.SymSet.to_seq |> List.of_seq in + let syms_l = syms |> Sym.Set.to_seq |> List.of_seq in let b = syms_l |> List.map (fun x -> Utils.create_binding x (C.mk_ctype_integer Size_t)) in @@ -486,7 +485,7 @@ let rec compile_term (AilEcall ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_SPLIT_END")), [ e_ty; e_tmp; e_size; mk_expr (AilEident last_var) ] - @ List.map wrap_to_string (List.of_seq (GR.SymSet.to_seq path_vars)) + @ List.map wrap_to_string (List.of_seq (Sym.Set.to_seq path_vars)) @ [ mk_expr (AilEconst ConstantNull) ] ))) ] in diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index 1036a6db9..11a6991df 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -10,8 +10,6 @@ module GT = GenTerms module GD = GenDefinitions module Config = TestGenConfig module CtA = Cn_internal_to_ail -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) type s = GD.context @@ -34,15 +32,15 @@ let compile_oargs (ret_bt : BT.t) (iargs : (Sym.t * BT.t) list) : (Sym.t * BT.t) let add_request - (recursive : SymSet.t) - (preds : (SymMap.key * RP.definition) list) + (recursive : Sym.Set.t) + (preds : (Sym.Map.key * RP.definition) list) (fsym : Sym.t) : unit m = let pred = List.assoc Sym.equal fsym preds in let gd : GD.t = { filename = Option.get (Cerb_location.get_filename pred.loc); - recursive = SymSet.mem fsym recursive; + recursive = Sym.Set.mem fsym recursive; spec = false; name = fsym; iargs = @@ -55,8 +53,8 @@ let add_request fun s -> ((), GD.add_context gd s) -let compile_vars (generated : SymSet.t) (oargs : (Sym.t * GBT.t) list) (lat : IT.t LAT.t) - : SymSet.t * (GT.t -> GT.t) +let compile_vars (generated : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) (lat : IT.t LAT.t) + : Sym.Set.t * (GT.t -> GT.t) = let backtrack_num = Config.get_max_backtracks () in let rec aux (xbts : (Sym.t * BT.t) list) : GT.t -> GT.t = @@ -71,14 +69,14 @@ let compile_vars (generated : SymSet.t) (oargs : (Sym.t * GBT.t) list) (lat : IT in let xs, xbts = match lat with - | Define ((x, it), _info, _) -> (SymSet.singleton x, IT.free_vars_bts it) + | Define ((x, it), _info, _) -> (Sym.Set.singleton x, IT.free_vars_bts it) | Resource ((x, ((P { name = Owned _; _ } as ret), bt)), _, _) -> - (SymSet.singleton x, SymMap.add x bt (RET.free_vars_bts ret)) - | Resource ((x, (ret, _)), _, _) -> (SymSet.singleton x, RET.free_vars_bts ret) - | Constraint (lc, _, _) -> (SymSet.empty, LC.free_vars_bts lc) + (Sym.Set.singleton x, Sym.Map.add x bt (RET.free_vars_bts ret)) + | Resource ((x, (ret, _)), _, _) -> (Sym.Set.singleton x, RET.free_vars_bts ret) + | Constraint (lc, _, _) -> (Sym.Set.empty, LC.free_vars_bts lc) | I it -> - ( SymSet.empty, - SymMap.union + ( Sym.Set.empty, + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) @@ -87,23 +85,23 @@ let compile_vars (generated : SymSet.t) (oargs : (Sym.t * GBT.t) list) (lat : IT |> List.filter (fun (x, _) -> not (Sym.equal x cn_return)) |> List.map_snd GBT.bt |> List.to_seq - |> SymMap.of_seq) ) + |> Sym.Map.of_seq) ) in let xbts = - xbts |> SymMap.filter (fun x _ -> not (SymSet.mem x generated)) |> SymMap.bindings + xbts |> Sym.Map.filter (fun x _ -> not (Sym.Set.mem x generated)) |> Sym.Map.bindings in let generated = - xbts |> List.map fst |> SymSet.of_list |> SymSet.union generated |> SymSet.union xs + xbts |> List.map fst |> Sym.Set.of_list |> Sym.Set.union generated |> Sym.Set.union xs in (generated, aux xbts) let rec compile_it_lat (filename : string) - (recursive : SymSet.t) + (recursive : Sym.Set.t) (preds : (Sym.t * RP.definition) list) (name : Sym.t) - (generated : SymSet.t) + (generated : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) (lat : IT.t LAT.t) : GT.t m @@ -122,7 +120,7 @@ let rec compile_it_lat let@ gt' = compile_it_lat filename recursive preds name generated oargs lat' in let gt_asgn = GT.asgn_ ((pointer, ct), IT.sym_ (x, bt, loc), gt') loc in let gt_val = - if SymSet.mem x generated then + if Sym.Set.mem x generated then gt_asgn else GT.let_ (backtrack_num, (x, GT.arbitrary_ bt loc), gt_asgn) loc @@ -271,10 +269,10 @@ let rec compile_it_lat let rec compile_clauses (filename : string) - (recursive : SymSet.t) + (recursive : Sym.Set.t) (preds : (Sym.t * RP.definition) list) (name : Sym.t) - (iargs : SymSet.t) + (iargs : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) (cls : RP.clause list) : GT.t m @@ -294,7 +292,7 @@ let rec compile_clauses let compile_pred - (recursive_preds : SymSet.t) + (recursive_preds : Sym.Set.t) (preds : (Sym.t * RP.definition) list) ({ filename; recursive; spec; name; iargs; oargs; body } : GD.t) : unit m @@ -307,7 +305,7 @@ let compile_pred recursive_preds preds name - (SymSet.of_list (List.map fst iargs)) + (Sym.Set.of_list (List.map fst iargs)) oargs (Option.get pred.clauses) in @@ -317,7 +315,7 @@ let compile_pred let compile_spec (filename : string) - (recursive : SymSet.t) + (recursive : Sym.Set.t) (preds : (Sym.t * RP.definition) list) (name : Sym.t) (at : 'a AT.t) @@ -330,8 +328,8 @@ let compile_spec let subst = let loc = Locations.other __LOC__ in lat - |> LAT.free_vars_bts (fun _ -> SymMap.empty) - |> SymMap.bindings + |> LAT.free_vars_bts (fun _ -> Sym.Map.empty) + |> Sym.Map.bindings |> List.map (fun (x, bt) -> (x, IT.sym_ (rename x, bt, loc))) |> IT.make_subst |> LAT.subst (fun _ x -> x) @@ -342,8 +340,8 @@ let compile_spec let oargs = let oargs' = lat - |> LAT.free_vars_bts (fun _ -> SymMap.empty) - |> SymMap.bindings + |> LAT.free_vars_bts (fun _ -> Sym.Map.empty) + |> Sym.Map.bindings |> List.map_snd GBT.of_bt in oargs' @@ -364,7 +362,7 @@ let compile_spec recursive preds name - SymSet.empty + Sym.Set.empty oargs (LAT.map (fun _ -> IT.unit_ here) lat) in diff --git a/backend/cn/lib/testGeneration/genDistribute.ml b/backend/cn/lib/testGeneration/genDistribute.ml index e368367c8..fa35412b2 100644 --- a/backend/cn/lib/testGeneration/genDistribute.ml +++ b/backend/cn/lib/testGeneration/genDistribute.ml @@ -4,8 +4,6 @@ module LC = LogicalConstraints module GT = GenTerms module GD = GenDefinitions module GA = GenAnalysis -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module Config = TestGenConfig let generated_size (bt : BT.t) : int = diff --git a/backend/cn/lib/testGeneration/genNormalize.ml b/backend/cn/lib/testGeneration/genNormalize.ml index a276346af..34946c9ec 100644 --- a/backend/cn/lib/testGeneration/genNormalize.ml +++ b/backend/cn/lib/testGeneration/genNormalize.ml @@ -3,7 +3,6 @@ module IT = IndexTerms module LC = LogicalConstraints module GT = GenTerms module GD = GenDefinitions -module SymMap = Map.Make (Sym) module MemberIndirection = struct type kind = diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index f77129d7e..94b3829b0 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -7,8 +7,6 @@ module GS = GenStatements module GD = GenDefinitions module GA = GenAnalysis module Config = TestGenConfig -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module StringSet = Set.Make (String) module StringMap = Map.Make (String) @@ -20,7 +18,7 @@ type opt_pass = module FlipIfs = struct (* TODO: Improve performance on runway example *) let transform (gd : GD.t) : GD.t = - let iargs = gd.iargs |> List.map fst |> SymSet.of_list in + let iargs = gd.iargs |> List.map fst |> Sym.Set.of_list in let rec aux (gt : GT.t) : GT.t = let (GT (gt_, _, loc)) = gt in match gt_ with @@ -28,7 +26,7 @@ module FlipIfs = struct | Pick wgts -> GT.pick_ (List.map_snd aux wgts) loc | ITE (it_if, gt_then, gt_else) -> let gt_then, gt_else = (aux gt_then, aux gt_else) in - if not (SymSet.subset (IT.free_vars it_if) iargs) then ( + if not (Sym.Set.subset (IT.free_vars it_if) iargs) then ( let wgts1 = match gt_then with | GT (Pick wgts, _, _) -> @@ -105,7 +103,7 @@ module Fusion = struct let collect_constraints - (vars : SymSet.t) + (vars : Sym.Set.t) (x : Sym.t) ((it_min, it_max) : IT.t * IT.t) (gt : GT.t) @@ -127,14 +125,14 @@ module Fusion = struct ( Forall ((i, i_bt), (IT (Binop (Implies, it_perm, it_body), _, loc_implies) as it)), gt' ) - when SymSet.mem x (IT.free_vars it) && check_index_ok x i it -> + when Sym.Set.mem x (IT.free_vars it) && check_index_ok x i it -> let it_min', it_max' = GA.get_bounds (i, i_bt) it_perm in let gt', res = aux gt' in if IT.equal it_min it_min' && IT.equal it_max it_max' - && SymSet.subset - (SymSet.remove i (IT.free_vars_list [ it_perm; it_body ])) + && Sym.Set.subset + (Sym.Set.remove i (IT.free_vars_list [ it_perm; it_body ])) vars then (gt', (i, IT.arith_binop Implies (it_perm, it_body) loc_implies) :: res) @@ -163,7 +161,7 @@ module Fusion = struct let transform (gd : GD.t) : GD.t = - let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t = + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -175,10 +173,10 @@ module Fusion = struct -> let its_bounds = GA.get_bounds (i, i_bt) it_perm in let gt_rest, constraints = - collect_constraints (SymSet.add x vars) x its_bounds gt_rest + collect_constraints (Sym.Set.add x vars) x its_bounds gt_rest in let gt_inner = - let stmts, gt_last = GS.stmts_of_gt (aux (SymSet.add i vars) gt_inner) in + let stmts, gt_last = GS.stmts_of_gt (aux (Sym.Set.add i vars) gt_inner) in let sym_bt, stmts', gt_last = match gt_last with | GT (Return (IT (Sym x, x_bt, _)), _, _) -> ((x, x_bt), [], gt_last) @@ -208,26 +206,26 @@ module Fusion = struct GT.let_ ( backtracks, (x, GT.map_ ((i, i_bt, it_perm), gt_inner) loc_map), - aux (SymSet.add x vars) gt_rest ) + aux (Sym.Set.add x vars) gt_rest ) loc | Let (backtracks, (x, gt_inner), gt_rest) -> GT.let_ - (backtracks, (x, aux vars gt_inner), aux (SymSet.add x vars) gt_rest) + (backtracks, (x, aux vars gt_inner), aux (Sym.Set.add x vars) gt_rest) loc | Assert (lc, gt') -> GT.assert_ (lc, aux vars gt') loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux vars gt_then, aux vars gt_else) loc | Map ((i, i_bt, it_perm), gt_inner) -> - GT.map_ ((i, i_bt, it_perm), aux (SymSet.add i vars) gt_inner) loc + GT.map_ ((i, i_bt, it_perm), aux (Sym.Set.add i vars) gt_inner) loc in let body = - Some (aux (gd.iargs |> List.map fst |> SymSet.of_list) (Option.get gd.body)) + Some (aux (gd.iargs |> List.map fst |> Sym.Set.of_list) (Option.get gd.body)) in { gd with body } end module Recursive = struct - let collect_constraints (vars : SymSet.t) (x : Sym.t) (gt : GT.t) : GT.t * LC.t list = + let collect_constraints (vars : Sym.Set.t) (x : Sym.t) (gt : GT.t) : GT.t * LC.t list = let rec aux (gt : GT.t) : GT.t * LC.t list = let (GT (gt_, _, loc)) = gt in match gt_ with @@ -250,7 +248,7 @@ module Fusion = struct (GT.assert_ (lc, gt_rest) loc, lcs) | Assert (lc, gt_rest) when let free_vars = LC.free_vars lc in - SymSet.mem x free_vars && SymSet.subset free_vars vars -> + Sym.Set.mem x free_vars && Sym.Set.subset free_vars vars -> let gt_rest, lcs = aux gt_rest in (gt_rest, lc :: lcs) | Assert (lc, gt_rest) -> @@ -269,8 +267,8 @@ module Fusion = struct constraints : LC.t list } - let request_gt (vars : SymSet.t) (gt : GT.t) : GT.t * inline_request list = - let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t * inline_request list = + let request_gt (vars : Sym.Set.t) (gt : GT.t) : GT.t * inline_request list = + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t * inline_request list = let (GT (gt_, _, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> (gt, []) @@ -287,8 +285,8 @@ module Fusion = struct let gt_rest, reqs = aux vars gt_rest in (GT.asgn_ ((it_addr, sct), it_val, gt_rest) loc, reqs) | Let (backtracks, (x, GT (Call (fsym, xits), bt_call, loc_call)), gt_rest) -> - let gt_rest, lcs = collect_constraints (SymSet.add x vars) x gt_rest in - let gt_rest, reqs = aux (SymSet.add x vars) gt_rest in + let gt_rest, lcs = collect_constraints (Sym.Set.add x vars) x gt_rest in + let gt_rest, reqs = aux (Sym.Set.add x vars) gt_rest in if List.is_empty lcs then ( GT.let_ (backtracks, (x, GT.call_ (fsym, xits) bt_call loc_call), gt_rest) @@ -301,12 +299,12 @@ module Fusion = struct lcs |> List.map LC.free_vars_bts |> List.fold_left - (SymMap.union (fun _ bt1 bt2 -> + (Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1)) - SymMap.empty - |> SymMap.remove x - |> SymMap.to_seq + Sym.Map.empty + |> Sym.Map.remove x + |> Sym.Map.to_seq |> List.of_seq |> List.map (fun (y, y_bt) -> (Sym.fresh (), IT.sym_ (y, y_bt, Locations.other __LOC__))) @@ -336,7 +334,7 @@ module Fusion = struct :: reqs )) | Let (backtracks, (x, gt_inner), gt_rest) -> let gt_inner, reqs = aux vars gt_inner in - let gt_rest, reqs' = aux (SymSet.add x vars) gt_rest in + let gt_rest, reqs' = aux (Sym.Set.add x vars) gt_rest in (GT.let_ (backtracks, (x, gt_inner), gt_rest) loc, reqs @ reqs') | Assert (lc, gt_rest) -> let gt_rest, reqs = aux vars gt_rest in @@ -346,7 +344,7 @@ module Fusion = struct let gt_else, reqs' = aux vars gt_else in (GT.ite_ (it_if, gt_then, gt_else) loc, reqs @ reqs') | Map ((i, i_bt, it_perm), gt_inner) -> - let gt_inner, reqs = aux (SymSet.add i vars) gt_inner in + let gt_inner, reqs = aux (Sym.Set.add i vars) gt_inner in (GT.map_ ((i, i_bt, it_perm), gt_inner) loc, reqs) in aux vars gt @@ -354,7 +352,7 @@ module Fusion = struct let request_gd (gd : GD.t) : GD.t * inline_request list = let gt, reqs = - request_gt (gd.iargs |> List.map fst |> SymSet.of_list) (Option.get gd.body) + request_gt (gd.iargs |> List.map fst |> Sym.Set.of_list) (Option.get gd.body) in ({ gd with body = Some gt }, reqs) @@ -740,18 +738,22 @@ module PartialEvaluation = struct let struct_decls = Pmap.fold (fun tag def decls -> - match def with Mucore.StructDef st -> SymMap.add tag st decls | _ -> decls) + match def with + | Mucore.StructDef st -> Sym.Map.add tag st decls + | _ -> decls) prog5.tagDefs - SymMap.empty + Sym.Map.empty in eval_aux (representable struct_decls ty it' here) | Good (ty, it') -> let struct_decls = Pmap.fold (fun tag def decls -> - match def with Mucore.StructDef st -> SymMap.add tag st decls | _ -> decls) + match def with + | Mucore.StructDef st -> Sym.Map.add tag st decls + | _ -> decls) prog5.tagDefs - SymMap.empty + Sym.Map.empty in eval_aux (good_value struct_decls ty it' here) | Aligned { t; align } -> @@ -1301,16 +1303,16 @@ module Inline = struct GT.map_gen_post aux gt - let of_symset (s : SymSet.t) : bool SymMap.t = - s |> SymSet.to_seq |> Seq.map (fun x -> (x, false)) |> SymMap.of_seq + let of_symset (s : Sym.Set.t) : bool Sym.Map.t = + s |> Sym.Set.to_seq |> Seq.map (fun x -> (x, false)) |> Sym.Map.of_seq - let union = SymMap.union (fun _ a b -> Some (not (a || b))) + let union = Sym.Map.union (fun _ a b -> Some (not (a || b))) - let rec transform_aux (gt : GT.t) : GT.t * bool SymMap.t = + let rec transform_aux (gt : GT.t) : GT.t * bool Sym.Map.t = let (GT (gt_, _, loc)) = gt in match gt_ with - | Arbitrary | Uniform _ -> (gt, SymMap.empty) + | Arbitrary | Uniform _ -> (gt, Sym.Map.empty) | Pick wgts -> let wgts, only_ret = wgts @@ -1318,7 +1320,7 @@ module Inline = struct |> List.map (fun (a, (b, c)) -> ((a, b), c)) |> List.split in - (GT.pick_ wgts loc, List.fold_left union SymMap.empty only_ret) + (GT.pick_ wgts loc, List.fold_left union Sym.Map.empty only_ret) | Alloc it -> (gt, it |> IT.free_vars |> of_symset) | Call (_fsym, xits) -> ( gt, @@ -1326,20 +1328,20 @@ module Inline = struct |> List.map snd |> List.map IT.free_vars |> List.map of_symset - |> List.fold_left union SymMap.empty ) + |> List.fold_left union Sym.Map.empty ) | Asgn ((it_addr, sct), it_val, gt') -> let only_ret = [ it_addr; it_val ] |> List.map IT.free_vars |> List.map of_symset - |> List.fold_left union SymMap.empty + |> List.fold_left union Sym.Map.empty in let gt', only_ret' = transform_aux gt' in (GT.asgn_ ((it_addr, sct), it_val, gt') loc, union only_ret only_ret') | Let (backtracks, (x, gt_inner), gt') -> let gt', only_ret = transform_aux gt' in - let only_ret = SymMap.remove x only_ret in - if Option.equal Bool.equal (SymMap.find_opt x only_ret) (Some true) then + let only_ret = Sym.Map.remove x only_ret in + if Option.equal Bool.equal (Sym.Map.find_opt x only_ret) (Some true) then (subst x gt_inner gt', only_ret) else ( let gt_inner, only_ret' = transform_aux gt_inner in @@ -1347,7 +1349,7 @@ module Inline = struct | Return it -> ( gt, (match IT.is_sym it with - | Some (x, _bt) -> SymMap.singleton x true + | Some (x, _bt) -> Sym.Map.singleton x true | None -> it |> IT.free_vars |> of_symset) ) | Assert (lc, gt') -> let only_ret = lc |> LC.free_vars |> of_symset in @@ -1358,11 +1360,11 @@ module Inline = struct let gt_then, only_ret' = transform_aux gt_then in let gt_else, only_ret'' = transform_aux gt_else in ( GT.ite_ (it_if, gt_then, gt_else) loc, - [ only_ret; only_ret'; only_ret'' ] |> List.fold_left union SymMap.empty ) + [ only_ret; only_ret'; only_ret'' ] |> List.fold_left union Sym.Map.empty ) | Map ((i, i_bt, it_perm), gt_inner) -> - let only_ret = it_perm |> IT.free_vars |> SymSet.remove i |> of_symset in + let only_ret = it_perm |> IT.free_vars |> Sym.Set.remove i |> of_symset in let gt_inner, only_ret' = transform_aux gt_inner in - let only_ret' = only_ret' |> SymMap.remove i |> SymMap.map (fun _ -> false) in + let only_ret' = only_ret' |> Sym.Map.remove i |> Sym.Map.map (fun _ -> false) in (GT.map_ ((i, i_bt, it_perm), gt_inner) loc, union only_ret only_ret') @@ -1444,7 +1446,7 @@ module SplitConstraints = struct it |> cnf |> listify_constraints - |> List.partition (fun it' -> SymSet.mem i_sym (IT.free_vars it')) + |> List.partition (fun it' -> Sym.Set.mem i_sym (IT.free_vars it')) in let gt_forall = GT.assert_ (LC.Forall ((i_sym, i_bt), IT.and_ its_in loc), gt') loc @@ -1568,7 +1570,7 @@ module SplitConstraints = struct let transform (gt : GT.t) : GT.t = - let rec aux (ext : SymSet.t) (gt : GT.t) : GT.t = + let rec aux (ext : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -1577,7 +1579,7 @@ module SplitConstraints = struct GT.asgn_ ((it_addr, sct), it_val, aux ext gt_rest) loc | Let (backtracks, (x, gt_inner), gt_rest) -> let gt_inner = aux ext gt_inner in - let ext = if is_external gt_inner then SymSet.add x ext else ext in + let ext = if is_external gt_inner then Sym.Set.add x ext else ext in GT.let_ (backtracks, (x, gt_inner), aux ext gt_rest) loc | Assert (T it, gt') -> let it = dnf it in @@ -1589,13 +1591,13 @@ module SplitConstraints = struct |> listify_constraints |> List.partition (fun it' -> match it with - | IT (Binop (EQ, IT (Sym x, _, _), _), _, _) when not (SymSet.mem x ext) + | IT (Binop (EQ, IT (Sym x, _, _), _), _, _) when not (Sym.Set.mem x ext) -> true - | IT (Binop (EQ, _, IT (Sym x, _, _)), _, _) when not (SymSet.mem x ext) + | IT (Binop (EQ, _, IT (Sym x, _, _)), _, _) when not (Sym.Set.mem x ext) -> true - | _ -> SymSet.disjoint ext (IT.free_vars it')) + | _ -> Sym.Set.disjoint ext (IT.free_vars it')) in let gt' = if List.is_empty its_left then @@ -1620,7 +1622,7 @@ module SplitConstraints = struct | Map ((i, i_bt, it_perm), gt_inner) -> GT.map_ ((i, i_bt, it_perm), aux ext gt_inner) loc in - aux SymSet.empty gt + aux Sym.Set.empty gt let pass = { name; transform } @@ -1653,7 +1655,7 @@ end (* module InferAllocationSize = struct let name = "infer_alloc_size" - let infer_size (vars : SymSet.t) (x : Sym.t) (gt : GT.t) : IT.t option = + let infer_size (vars : Sym.Set.t) (x : Sym.t) (gt : GT.t) : IT.t option = let merge loc oa ob = match (oa, ob) with | Some a, Some b -> Some (IT.max_ (a, b) loc) @@ -1674,7 +1676,7 @@ end let (IT (_, _, loc)) = it_addr in let open Option in let@ psym, it_offset = GA.get_addr_offset_opt it_addr in - if Sym.equal x psym && SymSet.subset (IT.free_vars it_offset) vars then + if Sym.equal x psym && Sym.Set.subset (IT.free_vars it_offset) vars then return (IT.add_ (it_offset, IT.sizeOf_ sct loc) loc) else None @@ -1693,7 +1695,7 @@ end in let open Option in let@ it = aux gt_inner in - if SymSet.mem j_sym (IT.free_vars it) then ( + if Sym.Set.mem j_sym (IT.free_vars it) then ( let _, it_max = GA.get_bounds (i_sym, i_bt) it_perm in return (IT.subst (IT.make_subst [ (j_sym, it_max) ]) it)) else @@ -1703,7 +1705,7 @@ end let transform (gd : GD.t) : GD.t = - let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t = + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -1712,7 +1714,7 @@ end GT.asgn_ ((it_addr, sct), it_val, aux vars gt_rest) loc | Let (backtracks, (x, (GT (Alloc it_size, _bt, loc_alloc) as gt_inner)), gt_rest) -> - let gt_rest = aux (SymSet.add x vars) gt_rest in + let gt_rest = aux (Sym.Set.add x vars) gt_rest in (match infer_size vars x gt_rest with | Some it_size' -> let here = Locations.other __LOC__ in @@ -1723,18 +1725,18 @@ end loc | None -> GT.let_ - (backtracks, (x, aux vars gt_inner), aux (SymSet.add x vars) gt_rest) + (backtracks, (x, aux vars gt_inner), aux (Sym.Set.add x vars) gt_rest) loc) | Let (backtracks, (x, gt_inner), gt_rest) -> - GT.let_ (backtracks, (x, aux vars gt_inner), aux (SymSet.add x vars) gt_rest) loc + GT.let_ (backtracks, (x, aux vars gt_inner), aux (Sym.Set.add x vars) gt_rest) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, aux vars gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux vars gt_then, aux vars gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymSet.add i_sym vars) gt_inner) loc + GT.map_ ((i_sym, i_bt, it_perm), aux (Sym.Set.add i_sym vars) gt_inner) loc in let body = - Some (aux (gd.iargs |> List.map fst |> SymSet.of_list) (Option.get gd.body)) + Some (aux (gd.iargs |> List.map fst |> Sym.Set.of_list) (Option.get gd.body)) in { gd with body } end *) @@ -1746,7 +1748,7 @@ module TermSimplification = struct let transform (prog5 : unit Mucore.file) (gt : GT.t) : GT.t = let globals = { Global.empty with - logical_functions = SymMap.of_seq (List.to_seq prog5.logical_predicates) + logical_functions = Sym.Map.of_seq (List.to_seq prog5.logical_predicates) } in let simp_it (it : IT.t) : IT.t = @@ -1941,7 +1943,7 @@ module RemoveUnused = struct let (GT (gt_, _, _)) = gt in match gt_ with | Let (_, (x, gt_inner), gt_rest) - when GA.is_pure gt_inner && not (SymSet.mem x (GT.free_vars gt_rest)) -> + when GA.is_pure gt_inner && not (Sym.Set.mem x (GT.free_vars gt_rest)) -> gt_rest | Assert (T it, gt_rest) when IT.is_true it -> gt_rest | _ -> gt @@ -1959,7 +1961,10 @@ module Reordering = struct module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) - let get_variable_ordering (_rec_fsyms : SymSet.t) (iargs : SymSet.t) (stmts : GS.t list) + let get_variable_ordering + (_rec_fsyms : Sym.Set.t) + (iargs : Sym.Set.t) + (stmts : GS.t list) : Sym.t list = let module Oper = Graph.Oper.P (SymGraph) in @@ -1972,55 +1977,55 @@ module Reordering = struct let g' = List.fold_left (fun g' y -> - if SymSet.mem y iargs || Sym.equal x y then + if Sym.Set.mem y iargs || Sym.equal x y then g' else SymGraph.add_edge_e g' (y, x)) g - (it |> IT.free_vars |> SymSet.to_seq |> List.of_seq) + (it |> IT.free_vars |> Sym.Set.to_seq |> List.of_seq) in g' | Assert (T (IT (Binop (EQ, it, IT (Sym x, _, _)), _, _))) :: stmts' -> let g = consider_equalities stmts' in Seq.fold_left (fun g' y -> - if SymSet.mem y iargs || Sym.equal x y then + if Sym.Set.mem y iargs || Sym.equal x y then g' else SymGraph.add_edge_e g' (y, x)) g - (it |> IT.free_vars |> SymSet.to_seq) + (it |> IT.free_vars |> Sym.Set.to_seq) | _ :: stmts' -> consider_equalities stmts' | [] -> SymGraph.empty in (* Put calls before local variables they constrain *) let rec consider_constrained_calls - (from_calls : SymSet.t) + (from_calls : Sym.Set.t) (g : SymGraph.t) (stmts : GS.t list) : SymGraph.t = match stmts with | Let (_, (x, gt)) :: stmts' when GT.contains_call gt -> - consider_constrained_calls (SymSet.add x from_calls) g stmts' + consider_constrained_calls (Sym.Set.add x from_calls) g stmts' | Asgn _ :: stmts' | Let _ :: stmts' -> consider_constrained_calls from_calls g stmts' | Assert lc :: stmts' -> let g = consider_constrained_calls from_calls g stmts' in let free_vars = LC.free_vars lc in - let call_vars = SymSet.inter free_vars from_calls in - let non_call_vars = SymSet.diff free_vars from_calls in + let call_vars = Sym.Set.inter free_vars from_calls in + let non_call_vars = Sym.Set.diff free_vars from_calls in let add_from_call (x : Sym.t) (g : SymGraph.t) : SymGraph.t = - SymSet.fold (fun y g' -> SymGraph.add_edge g' y x) call_vars g + Sym.Set.fold (fun y g' -> SymGraph.add_edge g' y x) call_vars g in - SymSet.fold add_from_call non_call_vars g + Sym.Set.fold add_from_call non_call_vars g | [] -> g in (* Describes logical dependencies where [x <- y] means that [x] depends on [y] *) let collect_constraints (stmts : GS.t list) : SymGraph.t = let g = consider_equalities stmts in let g' = Oper.transitive_closure g in - let g'' = consider_constrained_calls SymSet.empty g' stmts in + let g'' = consider_constrained_calls Sym.Set.empty g' stmts in let g''' = Oper.transitive_closure g'' in assert (not (SymGraph.fold_edges (fun x y acc -> Sym.equal x y || acc) g''' false)); g''' @@ -2031,9 +2036,9 @@ module Reordering = struct match stmts with | Let (_, (x, gt)) :: stmts' -> let g = SymGraph.add_vertex (aux stmts') x in - SymSet.fold + Sym.Set.fold (fun y g' -> - if SymSet.mem y iargs then + if Sym.Set.mem y iargs then g' else SymGraph.add_edge g' y x) @@ -2053,26 +2058,26 @@ module Reordering = struct let get_needs (x : Sym.t) (ys : Sym.t list) : Sym.t list = let syms_c = SymGraph.fold_pred - (fun y syms -> if List.mem Sym.equal y ys then syms else SymSet.add y syms) + (fun y syms -> if List.mem Sym.equal y ys then syms else Sym.Set.add y syms) g_c x - SymSet.empty + Sym.Set.empty in let syms = - SymSet.fold + Sym.Set.fold (fun z acc -> - SymSet.union + Sym.Set.union acc (SymGraph.fold_pred (fun y syms' -> - if List.mem Sym.equal y ys then syms' else SymSet.add y syms') + if List.mem Sym.equal y ys then syms' else Sym.Set.add y syms') g_d z - SymSet.empty)) + Sym.Set.empty)) syms_c syms_c in - orig_order |> List.filter (fun x -> SymSet.mem x syms) + orig_order |> List.filter (fun x -> Sym.Set.mem x syms) in let new_order : Sym.t list -> Sym.t list = List.fold_left @@ -2095,17 +2100,20 @@ module Reordering = struct loop orig_order - let get_statement_ordering (rec_fsyms : SymSet.t) (iargs : SymSet.t) (stmts : GS.t list) + let get_statement_ordering + (rec_fsyms : Sym.Set.t) + (iargs : Sym.Set.t) + (stmts : GS.t list) : GS.t list = - let rec loop (vars : SymSet.t) (syms : Sym.t list) (stmts : GS.t list) : GS.t list = + let rec loop (vars : Sym.Set.t) (syms : Sym.t list) (stmts : GS.t list) : GS.t list = let res, stmts' = List.partition (fun (stmt : GS.t) -> match stmt with | Asgn ((it_addr, _sct), it_val) -> - SymSet.subset (IT.free_vars_list [ it_addr; it_val ]) vars - | Assert lc -> SymSet.subset (LC.free_vars lc) vars + Sym.Set.subset (IT.free_vars_list [ it_addr; it_val ]) vars + | Assert lc -> Sym.Set.subset (LC.free_vars lc) vars | _ -> false) stmts in @@ -2117,7 +2125,7 @@ module Reordering = struct match stmt with Let (_, (x, _)) -> Sym.equal x sym | _ -> false) stmts' in - res @ res' @ loop (SymSet.add sym vars) syms' stmts'' + res @ res' @ loop (Sym.Set.add sym vars) syms' stmts'' | [] -> if List.non_empty stmts' then print_endline @@ -2125,7 +2133,7 @@ module Reordering = struct | [ Assert lc ] -> Pp.( LC.free_vars lc - |> SymSet.to_seq + |> Sym.Set.to_seq |> List.of_seq |> separate_map (comma ^^ space) Sym.pp |> plain) @@ -2136,7 +2144,7 @@ module Reordering = struct loop iargs syms stmts - let reorder (rec_fsyms : SymSet.t) (iargs : SymSet.t) (gt : GT.t) : GT.t = + let reorder (rec_fsyms : Sym.Set.t) (iargs : Sym.Set.t) (gt : GT.t) : GT.t = let stmts, gt_last = GS.stmts_of_gt gt in let stmts = get_statement_ordering rec_fsyms iargs stmts in GS.gt_of_stmts stmts gt_last @@ -2150,10 +2158,10 @@ module Reordering = struct |> List.map snd |> List.filter_map (fun (gd' : GD.t) -> if gd'.recursive then Some gd'.name else None) - |> SymSet.of_list + |> Sym.Set.of_list in - let rec aux (iargs : SymSet.t) (gt : GT.t) : GT.t = - let rec loop (iargs : SymSet.t) (gt : GT.t) : GT.t = + let rec aux (iargs : Sym.Set.t) (gt : GT.t) : GT.t = + let rec loop (iargs : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -2161,17 +2169,17 @@ module Reordering = struct | Asgn ((it_addr, sct), it_val, gt_rest) -> GT.asgn_ ((it_addr, sct), it_val, loop iargs gt_rest) loc | Let (backtracks, (x, gt'), gt_rest) -> - let iargs = SymSet.add x iargs in + let iargs = Sym.Set.add x iargs in GT.let_ (backtracks, (x, (aux iargs) gt'), loop iargs gt_rest) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, loop iargs gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux iargs gt_then, aux iargs gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymSet.add i_sym iargs) gt_inner) loc + GT.map_ ((i_sym, i_bt, it_perm), aux (Sym.Set.add i_sym iargs) gt_inner) loc in gt |> reorder rec_fsyms iargs |> loop iargs in - let iargs = gd.iargs |> List.map fst |> SymSet.of_list in + let iargs = gd.iargs |> List.map fst |> Sym.Set.of_list in { gd with body = Some (aux iargs (Option.get gd.body)) } end @@ -2690,18 +2698,18 @@ module ConstraintPropagation = struct module G = Graph.Persistent.Digraph.ConcreteLabeled (Sym) (Constraint) end - type t = Domain.t SymMap.t * G.t + type t = Domain.t Sym.Map.t * G.t - let empty = (SymMap.empty, G.empty) + let empty = (Sym.Map.empty, G.empty) - let variables ((ds, _) : t) : Domain.t SymMap.t = ds + let variables ((ds, _) : t) : Domain.t Sym.Map.t = ds let constraints ((_, g) : t) : (Sym.t * Constraint.t * Sym.t) list = G.fold_edges_e (fun edge edges -> edge :: edges) g [] let add_variable (x : Sym.t) (d : Domain.t) ((ds, g) : t) : t = - ( SymMap.update + ( Sym.Map.update x (fun od -> match od with Some d' -> Some (Domain.intersect d d') | None -> Some d) @@ -2720,9 +2728,9 @@ module ConstraintPropagation = struct (ds, g) - let domain (x : Sym.t) ((ds, _) : t) : Domain.t = SymMap.find x ds + let domain (x : Sym.t) ((ds, _) : t) : Domain.t = Sym.Map.find x ds - let domain_opt (x : Sym.t) ((ds, _) : t) : Domain.t option = SymMap.find_opt x ds + let domain_opt (x : Sym.t) ((ds, _) : t) : Domain.t option = Sym.Map.find_opt x ds let related_constraints ((_, g) : t) (x : Sym.t) : (Sym.t * Constraint.t * Sym.t) list = @@ -2755,13 +2763,13 @@ module ConstraintPropagation = struct let network = ConstraintNetwork.add_variable x - (Int (Option.get (IntRep.of_bt (SymMap.find x xbts)))) + (Int (Option.get (IntRep.of_bt (Sym.Map.find x xbts)))) network in let network = ConstraintNetwork.add_variable y - (Int (Option.get (IntRep.of_bt (SymMap.find y xbts)))) + (Int (Option.get (IntRep.of_bt (Sym.Map.find y xbts)))) network in (stmt :: stmts', ConstraintNetwork.add_constraint c x y network) @@ -2879,15 +2887,15 @@ module ConstraintPropagation = struct (** Adds new asserts encoding the domain information *) let add_refined_asserts - (iargs : BT.t SymMap.t) + (iargs : BT.t Sym.Map.t) (network : ConstraintNetwork.t) (stmts : GS.t list) : GS.t list = - let rec aux (ds : Domain.t SymMap.t) (stmts : GS.t list) : GS.t list = + let rec aux (ds : Domain.t Sym.Map.t) (stmts : GS.t list) : GS.t list = match stmts with - | (Let (_, (x, gt)) as stmt) :: stmts' when SymMap.mem x ds -> - (stmt :: Domain.to_stmts x (GT.bt gt) (SymMap.find x ds)) @ aux ds stmts' + | (Let (_, (x, gt)) as stmt) :: stmts' when Sym.Map.mem x ds -> + (stmt :: Domain.to_stmts x (GT.bt gt) (Sym.Map.find x ds)) @ aux ds stmts' | (Asgn _ as stmt) :: stmts' | (Let _ as stmt) :: stmts' | (Assert _ as stmt) :: stmts' -> @@ -2895,17 +2903,17 @@ module ConstraintPropagation = struct | [] -> [] in let ds = ConstraintNetwork.variables network in - let ds_iargs, ds_rest = SymMap.partition (fun x _ -> SymMap.mem x iargs) ds in + let ds_iargs, ds_rest = Sym.Map.partition (fun x _ -> Sym.Map.mem x iargs) ds in let stmts_iargs = - SymMap.fold - (fun x d acc -> Domain.to_stmts x (SymMap.find x iargs) d @ acc) + Sym.Map.fold + (fun x d acc -> Domain.to_stmts x (Sym.Map.find x iargs) d @ acc) ds_iargs [] in stmts_iargs @ aux ds_rest stmts - let propagate_constraints (iargs : BT.t SymMap.t) (gt : GT.t) : GT.t = + let propagate_constraints (iargs : BT.t Sym.Map.t) (gt : GT.t) : GT.t = let stmts, gt_last = GS.stmts_of_gt gt in let stmts, network = construct_network stmts in let network = ac3 network in @@ -2914,8 +2922,8 @@ module ConstraintPropagation = struct let transform (gd : GD.t) : GD.t = - let rec aux (iargs : BT.t SymMap.t) (gt : GT.t) : GT.t = - let rec loop (iargs : BT.t SymMap.t) (gt : GT.t) : GT.t = + let rec aux (iargs : BT.t Sym.Map.t) (gt : GT.t) : GT.t = + let rec loop (iargs : BT.t Sym.Map.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -2926,13 +2934,15 @@ module ConstraintPropagation = struct GT.let_ ( backtracks, (x, (aux iargs) gt'), - loop (SymMap.add x (GT.bt gt') iargs) gt_rest ) + loop (Sym.Map.add x (GT.bt gt') iargs) gt_rest ) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, loop iargs gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux iargs gt_then, aux iargs gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymMap.add i_sym i_bt iargs) gt_inner) loc + GT.map_ + ((i_sym, i_bt, it_perm), aux (Sym.Map.add i_sym i_bt iargs) gt_inner) + loc in gt |> propagate_constraints iargs |> loop iargs in @@ -2940,24 +2950,24 @@ module ConstraintPropagation = struct gd.iargs |> List.map (fun (x, gbt) -> (x, GenBaseTypes.bt gbt)) |> List.to_seq - |> SymMap.of_seq + |> Sym.Map.of_seq in { gd with body = Some (aux iargs (Option.get gd.body)) } end module Specialization = struct module Equality = struct - let find_constraint (vars : SymSet.t) (x : Sym.t) (stmts : GS.t list) + let find_constraint (vars : Sym.Set.t) (x : Sym.t) (stmts : GS.t list) : (GS.t list * IT.t) option = let rec aux (stmts : GS.t list) : (GS.t list * IT.t) option = let open Option in match stmts with | Assert (T (IT (Binop (EQ, IT (Sym x', _, _), it), _, _))) :: stmts' - when Sym.equal x x' && SymSet.subset (IT.free_vars it) vars -> + when Sym.equal x x' && Sym.Set.subset (IT.free_vars it) vars -> return (stmts', it) | Assert (T (IT (Binop (EQ, it, IT (Sym x', _, _)), _, _))) :: stmts' - when Sym.equal x x' && SymSet.subset (IT.free_vars it) vars -> + when Sym.equal x x' && Sym.Set.subset (IT.free_vars it) vars -> return (stmts', it) | stmt :: stmts' -> let@ stmts', it = aux stmts' in @@ -2967,8 +2977,8 @@ module Specialization = struct aux stmts - let specialize_stmts (vars : SymSet.t) (stmts : GS.t list) : GS.t list = - let rec aux (vars : SymSet.t) (stmts : GS.t list) : GS.t list = + let specialize_stmts (vars : Sym.Set.t) (stmts : GS.t list) : GS.t list = + let rec aux (vars : Sym.Set.t) (stmts : GS.t list) : GS.t list = match stmts with | Let (backtracks, (x, (GT (Arbitrary, _, loc) as gt))) :: stmts' | Let (backtracks, (x, (GT (Uniform _, _, loc) as gt))) :: stmts' @@ -2978,25 +2988,25 @@ module Specialization = struct | Some (stmts', it) -> (stmts', GT.return_ it loc) | None -> (stmts', gt) in - let vars = SymSet.add x vars in + let vars = Sym.Set.add x vars in GS.Let (backtracks, (x, gt)) :: aux vars stmts' - | (Let (_, (x, _)) as stmt) :: stmts' -> stmt :: aux (SymSet.add x vars) stmts' + | (Let (_, (x, _)) as stmt) :: stmts' -> stmt :: aux (Sym.Set.add x vars) stmts' | stmt :: stmts' -> stmt :: aux vars stmts' | [] -> [] in aux vars stmts - let specialize (vars : SymSet.t) (gt : GT.t) : GT.t = + let specialize (vars : Sym.Set.t) (gt : GT.t) : GT.t = let stmts, gt_last = GS.stmts_of_gt gt in let stmts = specialize_stmts vars stmts in GS.gt_of_stmts stmts gt_last let transform (gd : GD.t) : GD.t = - let iargs = gd.iargs |> List.map fst |> SymSet.of_list in - let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t = - let rec loop (vars : SymSet.t) (gt : GT.t) : GT.t = + let iargs = gd.iargs |> List.map fst |> Sym.Set.of_list in + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t = + let rec loop (vars : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -3005,13 +3015,13 @@ module Specialization = struct GT.asgn_ ((it_addr, sct), it_val, loop vars gt_rest) loc | Let (backtracks, (x, gt'), gt_rest) -> GT.let_ - (backtracks, (x, (aux vars) gt'), loop (SymSet.add x vars) gt_rest) + (backtracks, (x, (aux vars) gt'), loop (Sym.Set.add x vars) gt_rest) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, loop vars gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux vars gt_then, aux vars gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymSet.add i_sym vars) gt_inner) loc + GT.map_ ((i_sym, i_bt, it_perm), aux (Sym.Set.add i_sym vars) gt_inner) loc in gt |> specialize vars |> loop vars in @@ -3036,18 +3046,18 @@ module Specialization = struct let (IT (it_, _, _)) = it in match it_ with | Binop (LT, IT (Sym x', _, _), it') - when Sym.equal x x' && not (SymSet.mem x (IT.free_vars it')) -> + when Sym.equal x x' && not (Sym.Set.mem x (IT.free_vars it')) -> Some (of_max it') | Binop (LE, IT (Sym x', x_bt, _), it') - when Sym.equal x x' && not (SymSet.mem x (IT.free_vars it')) -> + when Sym.equal x x' && not (Sym.Set.mem x (IT.free_vars it')) -> let loc = Locations.other __LOC__ in Some (of_max (IT.add_ (it', IT.num_lit_ Z.one x_bt loc) loc)) | Binop (LT, it', IT (Sym x', x_bt, _)) - when Sym.equal x x' && not (SymSet.mem x (IT.free_vars it')) -> + when Sym.equal x x' && not (Sym.Set.mem x (IT.free_vars it')) -> let loc = Locations.other __LOC__ in Some (of_min (IT.sub_ (it', IT.num_lit_ Z.one x_bt loc) loc)) | Binop (LE, it', IT (Sym x', _, _)) - when Sym.equal x x' && not (SymSet.mem x (IT.free_vars it')) -> + when Sym.equal x x' && not (Sym.Set.mem x (IT.free_vars it')) -> Some (of_min it') | _ -> None @@ -3088,12 +3098,12 @@ module Specialization = struct { mult; min; max } end - let collect_constraints (vars : SymSet.t) (x : Sym.t) (bt : BT.t) (stmts : GS.t list) + let collect_constraints (vars : Sym.Set.t) (x : Sym.t) (bt : BT.t) (stmts : GS.t list) : GS.t list * Rep.t = let rec aux (stmts : GS.t list) : GS.t list * Rep.t = match stmts with - | (Assert (T it) as stmt) :: stmts' when SymSet.subset (IT.free_vars it) vars -> + | (Assert (T it) as stmt) :: stmts' when Sym.Set.subset (IT.free_vars it) vars -> let stmts', r = aux stmts' in (match Rep.of_it x it with | Some r' -> (stmts', Rep.intersect r r') @@ -3164,11 +3174,11 @@ module Specialization = struct | _ -> (gt, mult_to_stmt v.mult @ min_to_stmt v.min @ max_to_stmt v.max) - let specialize_stmts (vars : SymSet.t) (stmts : GS.t list) : GS.t list = - let rec aux (vars : SymSet.t) (stmts : GS.t list) : GS.t list = + let specialize_stmts (vars : Sym.Set.t) (stmts : GS.t list) : GS.t list = + let rec aux (vars : Sym.Set.t) (stmts : GS.t list) : GS.t list = match stmts with | Let (backtracks, (x, gt)) :: stmts' -> - let vars = SymSet.add x vars in + let vars = Sym.Set.add x vars in let stmts', (gt, stmts'') = if BT.equal (GT.bt gt) (BT.Loc ()) || Option.is_some (BT.is_bits_bt (GT.bt gt)) @@ -3185,15 +3195,15 @@ module Specialization = struct aux vars stmts - let specialize (vars : SymSet.t) (gt : GT.t) : GT.t = + let specialize (vars : Sym.Set.t) (gt : GT.t) : GT.t = let stmts, gt_last = GS.stmts_of_gt gt in let stmts = specialize_stmts vars stmts in GS.gt_of_stmts stmts gt_last let transform (gd : GD.t) : GD.t = - let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t = - let rec loop (vars : SymSet.t) (gt : GT.t) : GT.t = + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t = + let rec loop (vars : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -3202,17 +3212,17 @@ module Specialization = struct GT.asgn_ ((it_addr, sct), it_val, loop vars gt_rest) loc | Let (backtracks, (x, gt'), gt_rest) -> GT.let_ - (backtracks, (x, (aux vars) gt'), loop (SymSet.add x vars) gt_rest) + (backtracks, (x, (aux vars) gt'), loop (Sym.Set.add x vars) gt_rest) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, loop vars gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux vars gt_then, aux vars gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymSet.add i_sym vars) gt_inner) loc + GT.map_ ((i_sym, i_bt, it_perm), aux (Sym.Set.add i_sym vars) gt_inner) loc in gt |> specialize vars |> loop vars in - let iargs = gd.iargs |> List.map fst |> SymSet.of_list in + let iargs = gd.iargs |> List.map fst |> Sym.Set.of_list in { gd with body = Some (aux iargs (Option.get gd.body)) } end diff --git a/backend/cn/lib/testGeneration/genRuntime.ml b/backend/cn/lib/testGeneration/genRuntime.ml index abe1960ff..c58c0baef 100644 --- a/backend/cn/lib/testGeneration/genRuntime.ml +++ b/backend/cn/lib/testGeneration/genRuntime.ml @@ -7,8 +7,6 @@ module GT = GenTerms module GD = GenDefinitions module GBT = GenBaseTypes module GA = GenAnalysis -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) module StringMap = Map.Make (String) @@ -33,7 +31,7 @@ type term = { fsym : Sym.t; iargs : (Sym.t * Sym.t) list; oarg_bt : BT.t; - path_vars : SymSet.t; + path_vars : Sym.Set.t; sized : (int * Sym.t) option } | Asgn of @@ -75,8 +73,8 @@ type term = } | SplitSize of { marker_var : Sym.t; - syms : SymSet.t; - path_vars : SymSet.t; + syms : Sym.Set.t; + path_vars : Sym.Set.t; last_var : Sym.t; rest : term } @@ -84,34 +82,34 @@ type term = let is_return (tm : term) : bool = match tm with Return _ -> true | _ -> false -let rec free_vars_term (tm : term) : SymSet.t = +let rec free_vars_term (tm : term) : Sym.Set.t = match tm with - | Uniform _ -> SymSet.empty + | Uniform _ -> Sym.Set.empty | Pick { bt = _; choice_var = _; choices; last_var = _ } -> free_vars_term_list (List.map snd choices) | Alloc { bytes; sized = _ } -> IT.free_vars bytes | Call { fsym = _; iargs; oarg_bt = _; path_vars = _; sized = _ } -> - SymSet.of_list (List.map snd iargs) + Sym.Set.of_list (List.map snd iargs) | Asgn { pointer = _; addr; sct = _; value; last_var = _; rest } -> - SymSet.union (IT.free_vars_list [ addr; value ]) (free_vars_term rest) + Sym.Set.union (IT.free_vars_list [ addr; value ]) (free_vars_term rest) | Let { backtracks = _; x; x_bt = _; value; last_var = _; rest } -> - SymSet.union (free_vars_term value) (SymSet.remove x (free_vars_term rest)) + Sym.Set.union (free_vars_term value) (Sym.Set.remove x (free_vars_term rest)) | Return { value } -> IT.free_vars value | Assert { prop; last_var = _; rest } -> - SymSet.union (LC.free_vars prop) (free_vars_term rest) + Sym.Set.union (LC.free_vars prop) (free_vars_term rest) | ITE { bt = _; cond; t; f } -> - SymSet.union (IT.free_vars cond) (free_vars_term_list [ t; f ]) + Sym.Set.union (IT.free_vars cond) (free_vars_term_list [ t; f ]) | Map { i; bt = _; min; max; perm; inner; last_var = _ } -> - SymSet.remove + Sym.Set.remove i - (SymSet.union (IT.free_vars_list [ min; max; perm ]) (free_vars_term inner)) + (Sym.Set.union (IT.free_vars_list [ min; max; perm ]) (free_vars_term inner)) | SplitSize { marker_var = _; syms = _; path_vars = _; last_var = _; rest } -> free_vars_term rest -and free_vars_term_list : term list -> SymSet.t = +and free_vars_term_list : term list -> Sym.Set.t = fun xs -> - List.fold_left (fun ss t -> SymSet.union ss (free_vars_term t)) SymSet.empty xs + List.fold_left (fun ss t -> Sym.Set.union ss (free_vars_term t)) Sym.Set.empty xs let rec pp_term (tm : term) : Pp.document = @@ -167,7 +165,7 @@ let rec pp_term (tm : term) : Pp.document = ^^ separate_map (comma ^^ space) Sym.pp - (path_vars |> SymSet.to_seq |> List.of_seq))) + (path_vars |> Sym.Set.to_seq |> List.of_seq))) | Asgn { pointer; addr; sct; value; last_var; rest } -> Sctypes.pp sct ^^ space @@ -257,7 +255,7 @@ let rec pp_term (tm : term) : Pp.document = string "split_size" ^^ brackets (Sym.pp marker_var) ^^ parens - (separate_map (comma ^^ space) Sym.pp (syms |> SymSet.to_seq |> List.of_seq)) + (separate_map (comma ^^ space) Sym.pp (syms |> Sym.Set.to_seq |> List.of_seq)) ^^ space ^^ c_comment (string "backtracks to" @@ -270,13 +268,13 @@ let rec pp_term (tm : term) : Pp.document = ^^ separate_map (comma ^^ space) Sym.pp - (path_vars |> SymSet.to_seq |> List.of_seq)) + (path_vars |> Sym.Set.to_seq |> List.of_seq)) ^^ semi ^^ break 1 ^^ pp_term rest -let nice_names (inputs : SymSet.t) (gt : GT.t) : GT.t = +let nice_names (inputs : Sym.Set.t) (gt : GT.t) : GT.t = let basename (sym : Sym.t) : string = let open Sym in match description sym with @@ -342,12 +340,12 @@ let nice_names (inputs : SymSet.t) (gt : GT.t) : GT.t = in snd (aux - (inputs |> SymSet.to_seq |> Seq.map (fun x -> (basename x, 1)) |> StringMap.of_seq) + (inputs |> Sym.Set.to_seq |> Seq.map (fun x -> (basename x, 1)) |> StringMap.of_seq) gt) -let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = - let rec aux (vars : Sym.t list) (path_vars : SymSet.t) (gt : GT.t) : term = +let elaborate_gt (inputs : Sym.Set.t) (gt : GT.t) : term = + let rec aux (vars : Sym.t list) (path_vars : Sym.Set.t) (gt : GT.t) : term = let last_var = match vars with v :: _ -> v | [] -> bennet in let (GT (gt_, bt, loc)) = gt in match gt_ with @@ -384,7 +382,7 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = in List.map (fun (w, gt) -> - (f w, aux (choice_var :: vars) (SymSet.add choice_var path_vars) gt)) + (f w, aux (choice_var :: vars) (Sym.Set.add choice_var path_vars) gt)) wgts); last_var } @@ -416,12 +414,12 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = let pointer = let pointers = let free_vars = IT.free_vars_bts addr in - if SymMap.cardinal free_vars == 1 then + if Sym.Map.cardinal free_vars == 1 then free_vars else - free_vars |> SymMap.filter (fun _ bt -> BT.equal bt (BT.Loc ())) + free_vars |> Sym.Map.filter (fun _ bt -> BT.equal bt (BT.Loc ())) in - if not (SymMap.cardinal pointers == 1) then + if not (Sym.Map.cardinal pointers == 1) then Cerb_debug.print_debug 2 [] (fun () -> Pp.( plain @@ -429,13 +427,13 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = (separate_map (comma ^^ space) Sym.pp - (List.map fst (SymMap.bindings pointers))) + (List.map fst (Sym.Map.bindings pointers))) ^^ space ^^ string " in " ^^ IT.pp addr))); List.find - (fun x -> SymMap.mem x pointers) - (vars @ List.of_seq (SymSet.to_seq inputs)) + (fun x -> Sym.Map.mem x pointers) + (vars @ List.of_seq (Sym.Set.to_seq inputs)) in Asgn { pointer; addr; sct; value; last_var; rest = aux vars path_vars rest } | Let (backtracks, (x, gt1), gt2) -> @@ -450,7 +448,7 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = | Return value -> Return { value } | Assert (prop, rest) -> Assert { prop; last_var; rest = aux vars path_vars rest } | ITE (cond, gt_then, gt_else) -> - let path_vars = SymSet.union path_vars (IT.free_vars cond) in + let path_vars = Sym.Set.union path_vars (IT.free_vars cond) in ITE { bt; cond; t = aux vars path_vars gt_then; f = aux vars path_vars gt_else } | Map ((i, i_bt, perm), inner) -> let min, max = GenAnalysis.get_bounds (i, i_bt) perm in @@ -464,7 +462,7 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = last_var } in - aux [] SymSet.empty (nice_names inputs gt) + aux [] Sym.Set.empty (nice_names inputs gt) type definition = @@ -512,7 +510,7 @@ let elaborate_gd ({ filename; recursive; spec = _; name; iargs; oargs; body } : body = Option.get body |> GenNormalize.MemberIndirection.transform - |> elaborate_gt (SymSet.of_list (List.map fst iargs)) + |> elaborate_gt (Sym.Set.of_list (List.map fst iargs)) } @@ -533,13 +531,13 @@ let pp (ctx : context) : Pp.document = module Sizing = struct - let count_recursive_calls (syms : SymSet.t) (gr : term) : int = + let count_recursive_calls (syms : Sym.Set.t) (gr : term) : int = let rec aux (gr : term) : int = match gr with | Uniform _ | Alloc _ | Return _ -> 0 | Pick { choices; _ } -> choices |> List.map snd |> List.map aux |> List.fold_left max 0 - | Call { fsym; _ } -> if SymSet.mem fsym syms then 1 else 0 + | Call { fsym; _ } -> if Sym.Set.mem fsym syms then 1 else 0 | Asgn { rest; _ } -> aux rest | Let { value; rest; _ } -> aux value + aux rest | Assert { rest; _ } -> aux rest @@ -550,26 +548,30 @@ module Sizing = struct aux gr - let size_recursive_calls (marker_var : Sym.t) (syms : SymSet.t) (size : int) (gr : term) - : term * SymSet.t + let size_recursive_calls + (marker_var : Sym.t) + (syms : Sym.Set.t) + (size : int) + (gr : term) + : term * Sym.Set.t = - let rec aux (gr : term) : term * SymSet.t = + let rec aux (gr : term) : term * Sym.Set.t = match gr with - | Call ({ fsym; path_vars; _ } as gr) when SymSet.mem fsym syms -> + | Call ({ fsym; path_vars; _ } as gr) when Sym.Set.mem fsym syms -> let sym = Sym.fresh () in let gr' = if size > 1 && TestGenConfig.is_random_size_splits () then Call { gr with sized = Some (size, sym); - path_vars = SymSet.add marker_var path_vars + path_vars = Sym.Set.add marker_var path_vars } else Call { gr with sized = Some (size, sym) } in - (gr', SymSet.singleton sym) - | Uniform _ | Call _ | Return _ -> (gr, SymSet.empty) - | Alloc { bytes; sized = _ } -> (Alloc { bytes; sized = true }, SymSet.empty) + (gr', Sym.Set.singleton sym) + | Uniform _ | Call _ | Return _ -> (gr, Sym.Set.empty) + | Alloc { bytes; sized = _ } -> (Alloc { bytes; sized = true }, Sym.Set.empty) | Pick ({ choices; _ } as gr) -> let choices, syms = choices @@ -578,21 +580,21 @@ module Sizing = struct ((w, gr), syms)) |> List.split in - (Pick { gr with choices }, List.fold_left SymSet.union SymSet.empty syms) + (Pick { gr with choices }, List.fold_left Sym.Set.union Sym.Set.empty syms) | Asgn ({ rest; _ } as gr) -> let rest, syms = aux rest in (Asgn { gr with rest }, syms) | Let ({ value; rest; _ } as gr) -> let value, syms = aux value in let rest, syms' = aux rest in - (Let { gr with value; rest }, SymSet.union syms syms') + (Let { gr with value; rest }, Sym.Set.union syms syms') | Assert ({ rest; _ } as gr) -> let rest, syms = aux rest in (Assert { gr with rest }, syms) | ITE ({ t; f; _ } as gr) -> let t, syms = aux t in let f, syms' = aux f in - (ITE { gr with t; f }, SymSet.union syms syms') + (ITE { gr with t; f }, Sym.Set.union syms syms') | Map ({ inner; _ } as gr) -> let inner, syms = aux inner in (Map { gr with inner }, syms) @@ -601,17 +603,17 @@ module Sizing = struct aux gr - let transform_gr (syms : SymSet.t) (gr : term) : term = - let rec aux (path_vars : SymSet.t) (gr : term) : term = + let transform_gr (syms : Sym.Set.t) (gr : term) : term = + let rec aux (path_vars : Sym.Set.t) (gr : term) : term = match gr with | ITE { bt; cond; t; f } -> - let path_vars = SymSet.union path_vars (IT.free_vars cond) in + let path_vars = Sym.Set.union path_vars (IT.free_vars cond) in ITE { bt; cond; t = aux path_vars t; f = aux path_vars f } | Pick { bt; choice_var; choices; last_var } -> Pick { bt; choice_var; - choices = List.map_snd (aux (SymSet.add choice_var path_vars)) choices; + choices = List.map_snd (aux (Sym.Set.add choice_var path_vars)) choices; last_var } | _ -> @@ -629,16 +631,16 @@ module Sizing = struct else gr in - aux SymSet.empty gr + aux Sym.Set.empty gr let transform_def (cg : SymGraph.t) ({ filename : string; sized : bool; - name : SymSet.elt; - iargs : (SymSet.elt * BT.t) list; - oargs : (SymSet.elt * BT.t) list; + name : Sym.Set.elt; + iargs : (Sym.Set.elt * BT.t) list; + oargs : (Sym.Set.elt * BT.t) list; body : term } : definition) @@ -649,7 +651,7 @@ module Sizing = struct name; iargs; oargs; - body = transform_gr (SymGraph.fold_pred SymSet.add cg name SymSet.empty) body + body = transform_gr (SymGraph.fold_pred Sym.Set.add cg name Sym.Set.empty) body } diff --git a/backend/cn/lib/testGeneration/genRuntime.mli b/backend/cn/lib/testGeneration/genRuntime.mli index b924008b8..9e1c5ce24 100644 --- a/backend/cn/lib/testGeneration/genRuntime.mli +++ b/backend/cn/lib/testGeneration/genRuntime.mli @@ -5,8 +5,6 @@ module IT = IndexTerms module LC = LogicalConstraints module GD = GenDefinitions -module SymSet : Set.S with type elt = Sym.t - type term = | Uniform of { bt : BT.t; @@ -26,7 +24,7 @@ type term = { fsym : Sym.t; iargs : (Sym.t * Sym.t) list; oarg_bt : BT.t; - path_vars : SymSet.t; + path_vars : Sym.Set.t; sized : (int * Sym.t) option } | Asgn of @@ -68,16 +66,16 @@ type term = } | SplitSize of { marker_var : Sym.t; - syms : SymSet.t; - path_vars : SymSet.t; + syms : Sym.Set.t; + path_vars : Sym.Set.t; last_var : Sym.t; rest : term } [@@deriving eq, ord] -val free_vars_term : term -> SymSet.t +val free_vars_term : term -> Sym.Set.t -val free_vars_term_list : term list -> SymSet.t +val free_vars_term_list : term list -> Sym.Set.t val pp_term : term -> Pp.document diff --git a/backend/cn/lib/testGeneration/genTerms.ml b/backend/cn/lib/testGeneration/genTerms.ml index 6cdce4587..6d6accd72 100644 --- a/backend/cn/lib/testGeneration/genTerms.ml +++ b/backend/cn/lib/testGeneration/genTerms.ml @@ -3,8 +3,6 @@ module IT = IndexTerms module LC = LogicalConstraints module CF = Cerb_frontend module GBT = GenBaseTypes -module SymMap = Map.Make (Sym) -module SymSet = Set.Make (Sym) type t_ = | Arbitrary (** Generate arbitrary values *) @@ -263,31 +261,31 @@ and alpha_rename_gen x gt = and suitably_alpha_rename_gen syms x gt = - if SymSet.mem x syms then + if Sym.Set.mem x syms then alpha_rename_gen x gt else (x, gt) -let rec free_vars_bts_ (gt_ : t_) : BT.t SymMap.t = +let rec free_vars_bts_ (gt_ : t_) : BT.t Sym.Map.t = let loc = Locations.other __LOC__ in match gt_ with - | Arbitrary | Uniform _ -> SymMap.empty + | Arbitrary | Uniform _ -> Sym.Map.empty | Pick wgts -> free_vars_bts_list (List.map snd wgts) | Alloc it -> IT.free_vars_bts it | Call (_, xits) -> IT.free_vars_bts_list (List.map snd xits) | Asgn ((it_addr, _), it_val, gt') -> free_vars_bts_list [ return_ it_addr loc; return_ it_val loc; gt' ] | Let (_, (x, gt1), gt2) -> - SymMap.union + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) (free_vars_bts gt1) - (SymMap.remove x (free_vars_bts gt2)) + (Sym.Map.remove x (free_vars_bts gt2)) | Return it -> IT.free_vars_bts it | Assert (lc, gt') -> - (SymMap.union (fun _ bt1 bt2 -> + (Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1)) (free_vars_bts gt') @@ -295,27 +293,27 @@ let rec free_vars_bts_ (gt_ : t_) : BT.t SymMap.t = | ITE (it_if, gt_then, gt_else) -> free_vars_bts_list [ return_ it_if loc; gt_then; gt_else ] | Map ((i, _bt, it_perm), gt') -> - SymMap.remove i (free_vars_bts_list [ return_ it_perm loc; gt' ]) + Sym.Map.remove i (free_vars_bts_list [ return_ it_perm loc; gt' ]) -and free_vars_bts (GT (gt_, _, _) : t) : BT.t SymMap.t = free_vars_bts_ gt_ +and free_vars_bts (GT (gt_, _, _) : t) : BT.t Sym.Map.t = free_vars_bts_ gt_ -and free_vars_bts_list : t list -> BT.t SymMap.t = +and free_vars_bts_list : t list -> BT.t Sym.Map.t = fun xs -> List.fold_left (fun ss t -> - SymMap.union + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) ss (free_vars_bts t)) - SymMap.empty + Sym.Map.empty xs -let free_vars (gt : t) : SymSet.t = - gt |> free_vars_bts |> SymMap.bindings |> List.map fst |> SymSet.of_list +let free_vars (gt : t) : Sym.Set.t = + gt |> free_vars_bts |> Sym.Map.bindings |> List.map fst |> Sym.Set.of_list let rec map_gen_pre (f : t -> t) (g : t) : t = diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index cba09cfcf..9709f2ccd 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -8,7 +8,6 @@ module CtA = Cn_internal_to_ail module Utils = Executable_spec_utils module ESpecInternal = Executable_spec_internal module Config = TestGenConfig -module SymSet = Set.Make (Sym) let debug_log_file : out_channel option ref = ref None @@ -91,8 +90,8 @@ let compile_random_test_case inst.internal |> Option.get |> AT.get_lat - |> LAT.free_vars (fun _ -> SymSet.empty) - |> SymSet.to_seq + |> LAT.free_vars (fun _ -> Sym.Set.empty) + |> Sym.Set.to_seq |> List.of_seq |> List.filter (fun x -> not @@ -268,8 +267,8 @@ let should_be_unit_test match decl with | Decl_function (_, _, args, _, _, _) -> List.is_empty args - && SymSet.is_empty - (LAT.free_vars (fun _ -> SymSet.empty) (AT.get_lat (Option.get inst.internal))) + && Sym.Set.is_empty + (LAT.free_vars (fun _ -> Sym.Set.empty) (AT.get_lat (Option.get inst.internal))) | Decl_object _ -> failwith __LOC__ @@ -590,7 +589,7 @@ let generate let insts = prog5 |> Executable_spec_extract.collect_instrumentation |> fst in let selected_fsyms = Check.select_functions - (SymSet.of_list + (Sym.Set.of_list (List.map (fun (inst : Executable_spec_extract.instrumentation) -> inst.fn) insts)) @@ -598,7 +597,7 @@ let generate let insts = insts |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> - Option.is_some inst.internal && SymSet.mem inst.fn selected_fsyms) + Option.is_some inst.internal && Sym.Set.mem inst.fn selected_fsyms) in if List.is_empty insts then failwith "No testable functions"; let filename_base = filename |> Filename.basename |> Filename.chop_extension in diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 1ccd4cd81..23d72dea4 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -1,7 +1,6 @@ open Context module IT = IndexTerms module ITSet = Set.Make (IT) -module SymMap = Map.Make (Sym) module RET = ResourceTypes module RE = Resources open TypeErrors @@ -11,7 +10,7 @@ type solver = Solver.solver type s = { typing_context : Context.t; solver : solver option; - sym_eqs : IT.t SymMap.t; + sym_eqs : IT.t Sym.Map.t; past_models : (Solver.model_with_q * Context.t) list; found_equalities : EqTable.table; movable_indices : (RET.predicate_name * IT.t) list; @@ -22,7 +21,7 @@ type s = let empty_s (c : Context.t) = { typing_context = c; solver = None; - sym_eqs = SymMap.empty; + sym_eqs = Sym.Map.empty; past_models = []; found_equalities = EqTable.empty; movable_indices = []; @@ -224,21 +223,21 @@ let get_logical_function_def loc id = let get_struct_decl loc tag = let@ global = get_global () in - match SymMap.find_opt tag global.struct_decls with + match Sym.Map.find_opt tag global.struct_decls with | Some decl -> return decl | None -> fail (fun _ -> { loc; msg = Unknown_struct tag }) let get_datatype loc tag = let@ global = get_global () in - match SymMap.find_opt tag global.datatypes with + match Sym.Map.find_opt tag global.datatypes with | Some dt -> return dt | None -> fail (fun _ -> { loc; msg = Unknown_datatype tag }) let get_datatype_constr loc tag = let@ global = get_global () in - match SymMap.find_opt tag global.datatype_constrs with + match Sym.Map.find_opt tag global.datatype_constrs with | Some info -> return info | None -> fail (fun _ -> { loc; msg = Unknown_datatype_constr tag }) @@ -286,44 +285,42 @@ let get_resource_predicate_def loc id = let add_struct_decl tag layout : unit m = let@ global = get_global () in - set_global { global with struct_decls = SymMap.add tag layout global.struct_decls } + set_global { global with struct_decls = Sym.Map.add tag layout global.struct_decls } let add_fun_decl fname entry = let@ global = get_global () in - set_global { global with fun_decls = SymMap.add fname entry global.fun_decls } + set_global { global with fun_decls = Sym.Map.add fname entry global.fun_decls } let add_lemma lemma_s (loc, lemma_typ) = let@ global = get_global () in - set_global { global with lemmata = SymMap.add lemma_s (loc, lemma_typ) global.lemmata } + set_global { global with lemmata = Sym.Map.add lemma_s (loc, lemma_typ) global.lemmata } let add_resource_predicate name entry = let@ global = get_global () in set_global { global with - resource_predicates = Global.SymMap.add name entry global.resource_predicates + resource_predicates = Sym.Map.add name entry global.resource_predicates } let add_logical_function name entry = let@ global = get_global () in set_global - { global with - logical_functions = Global.SymMap.add name entry global.logical_functions - } + { global with logical_functions = Sym.Map.add name entry global.logical_functions } let add_datatype name entry = let@ global = get_global () in - set_global { global with datatypes = SymMap.add name entry global.datatypes } + set_global { global with datatypes = Sym.Map.add name entry global.datatypes } let add_datatype_constr name entry = let@ global = get_global () in set_global - { global with datatype_constrs = SymMap.add name entry global.datatype_constrs } + { global with datatype_constrs = Sym.Map.add name entry global.datatype_constrs } let set_datatype_order datatype_order = @@ -341,7 +338,7 @@ let get_datatype_order () = let add_sym_eqs sym_eqs = modify (fun s -> let sym_eqs = - List.fold_left (fun acc (s, v) -> SymMap.add s v acc) s.sym_eqs sym_eqs + List.fold_left (fun acc (s, v) -> Sym.Map.add s v acc) s.sym_eqs sym_eqs in { s with sym_eqs }) @@ -526,7 +523,7 @@ let do_check_model loc m prop = let@ global = get_global () in let vs = Context.( - SymMap.bindings ctxt.computational @ SymMap.bindings ctxt.logical + Sym.Map.bindings ctxt.computational @ Sym.Map.bindings ctxt.logical |> List.filter (fun (_, (bt_or_v, _)) -> not (has_value bt_or_v)) |> List.map (fun (nm, (bt_or_v, (loc, _))) -> IT.sym_ (nm, bt_of bt_or_v, loc))) in diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 58f885352..f70be7b85 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -1,7 +1,6 @@ module CF = Cerb_frontend module LS = LogicalSorts module BT = BaseTypes -module SymSet = Set.Make (Sym) module TE = TypeErrors module RE = Resources module RET = ResourceTypes @@ -1373,13 +1372,12 @@ end module BaseTyping = struct open Typing open TypeErrors - module SymMap = Map.Make (Sym) module BT = BaseTypes module RT = ReturnTypes module AT = ArgumentTypes open BT - type label_context = (AT.lt * label_kind * Locations.t) SymMap.t + type label_context = (AT.lt * label_kind * Locations.t) Sym.Map.t let check_against_core_bt loc msg2 cbt bt = Typing.embed_resultat @@ -2117,7 +2115,7 @@ module BaseTyping = struct | Erun (l, pes) -> (* copying from check.ml *) let@ lt, _lkind = - match SymMap.find_opt l label_context with + match Sym.Map.find_opt l label_context with | None -> fail (fun _ -> { loc; msg = Generic (!^"undefined code label" ^/^ Sym.pp l) }) @@ -2200,9 +2198,9 @@ module WProc = struct in (*debug 6 (lazy (!^"label type within function" ^^^ Sym.pp fsym)); debug 6 (lazy (CF.Pp_ast.pp_doc_tree (AT.dtree False.dtree lt)));*) - SymMap.add sym (lt, kind, loc) label_context) + Sym.Map.add sym (lt, kind, loc) label_context) label_defs - SymMap.empty + Sym.Map.empty let typ p = WArgs.typ (fun (_body, _labels, rt) -> rt) p @@ -2411,7 +2409,7 @@ module WDT = struct let@ () = ListM.iterM (fun scc -> - let scc_set = SymSet.of_list scc in + let scc_set = Sym.Set.of_list scc in ListM.iterM (fun dt -> let { loc; cases } = List.assoc Sym.equal dt datatypes in @@ -2420,11 +2418,11 @@ module WDT = struct ListM.iterM (fun (id, bt) -> let indirect_deps = - SymSet.of_list + Sym.Set.of_list (List.filter_map BT.is_datatype_bt (BT.contained bt)) in - let bad = SymSet.inter indirect_deps scc_set in - match SymSet.elements bad with + let bad = Sym.Set.inter indirect_deps scc_set in + match Sym.Set.elements bad with | [] -> return () | dt' :: _ -> let err = From dd878592d091dfea080a073d54c3003ff3b41b78 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 15:30:14 +0000 Subject: [PATCH 091/148] Unify all logical constraint sets --- backend/cn/lib/check.ml | 2 +- backend/cn/lib/context.ml | 15 +++++++-------- backend/cn/lib/diagnostics.ml | 3 +-- backend/cn/lib/explain.ml | 2 +- backend/cn/lib/logicalConstraints.ml | 11 ++++++++--- backend/cn/lib/resourceInference.ml | 2 +- backend/cn/lib/resourceTypes.ml | 1 - backend/cn/lib/resourceTypes.mli | 3 --- backend/cn/lib/resources.ml | 1 - backend/cn/lib/simplify.ml | 1 - backend/cn/lib/solver.ml | 3 +-- backend/cn/lib/solver.mli | 4 ++-- backend/cn/lib/typing.ml | 2 +- backend/cn/lib/typing.mli | 2 +- 14 files changed, 24 insertions(+), 28 deletions(-) diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 9e86387c5..a11921ed3 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -1216,7 +1216,7 @@ let instantiate loc filter arg = let extra_assumptions1 = List.filter_map (function LC.Forall ((s, bt), t) when filter t -> Some ((s, bt), t) | _ -> None) - (ResourceTypes.LCSet.elements constraints) + (LC.Set.elements constraints) in let extra_assumptions2, type_mismatch = List.partition (fun ((_, bt), _) -> BT.equal bt (IT.bt arg_it)) extra_assumptions1 diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index 4d1314c75..e42c1d5cb 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -4,7 +4,6 @@ module BT = BaseTypes module LS = LogicalSorts module RE = Resources module LC = LogicalConstraints -module LCSet = Set.Make (LC) module Loc = Locations module IntMap = Map.Make (Int) @@ -39,7 +38,7 @@ type t = logical : (basetype_or_value * l_info) Sym.Map.t; resources : (RE.t * int) list * int; resource_history : resource_history IntMap.t; - constraints : LCSet.t; + constraints : LC.Set.t; global : Global.t; where : Where.t } @@ -54,7 +53,7 @@ let empty = logical; resources = ([], 0); resource_history = IntMap.empty; - constraints = LCSet.empty; + constraints = LC.Set.empty; global = Global.empty; where = Where.empty } @@ -80,7 +79,7 @@ let pp_constraints constraints = LC.pp lc else parens !^"...") - (LCSet.elements constraints) + (LC.Set.elements constraints) let pp (ctxt : t) = @@ -140,10 +139,10 @@ let remove_a s ctxt = let add_c c (ctxt : t) = let s = ctxt.constraints in - if LCSet.mem c s then + if LC.Set.mem c s then ctxt else - { ctxt with constraints = LCSet.add c s } + { ctxt with constraints = LC.Set.add c s } let modify_where (f : Where.t -> Where.t) ctxt = { ctxt with where = f ctxt.where } @@ -254,7 +253,7 @@ let json (ctxt : t) : Yojson.Safe.t = (Sym.Map.bindings ctxt.logical) in let resources = List.map RE.json (get_rs ctxt) in - let constraints = List.map LC.json (LCSet.elements ctxt.constraints) in + let constraints = List.map LC.json (LC.Set.elements ctxt.constraints) in let json_record = `Assoc [ ("computational", `List computational); @@ -271,7 +270,7 @@ let json (ctxt : t) : Yojson.Safe.t = let not_given_to_solver ctxt = let global = ctxt.global in let constraints = - filter LogicalConstraints.is_forall (LCSet.elements ctxt.constraints) + filter LogicalConstraints.is_forall (LC.Set.elements ctxt.constraints) in let funs = Sym.Map.bindings diff --git a/backend/cn/lib/diagnostics.ml b/backend/cn/lib/diagnostics.ml index 735e2e39f..0c06282c9 100644 --- a/backend/cn/lib/diagnostics.ml +++ b/backend/cn/lib/diagnostics.ml @@ -1,6 +1,5 @@ open Typing module LC = LogicalConstraints -module LCSet = Set.Make (LC) module IT = IndexTerms open Effectful.Make (Typing) @@ -88,7 +87,7 @@ let rec bool_subterms_of t = let constraint_ts () = let@ cs = get_cs () in let ts = - List.filter_map (function LC.T t -> Some t | _ -> None) (LCSet.elements cs) + List.filter_map (function LC.T t -> Some t | _ -> None) (LC.Set.elements cs) in return ts diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index 4429e9b0f..120e4ac8d 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -182,7 +182,7 @@ let state ctxt log model_with_q extras = | LC.T (IT (Representable _, _, _)) -> false | LC.T (IT (Good _, _, _)) -> false | _ -> true) - (LCSet.elements ctxt.constraints) + (LC.Set.elements ctxt.constraints) in let not_given_to_solver = (* get predicates from past steps of trace not given to solver *) diff --git a/backend/cn/lib/logicalConstraints.ml b/backend/cn/lib/logicalConstraints.ml index 99bd54df5..c240db8f1 100644 --- a/backend/cn/lib/logicalConstraints.ml +++ b/backend/cn/lib/logicalConstraints.ml @@ -7,11 +7,16 @@ type logical_constraint = | Forall of (Sym.t * BT.t) * IT.t [@@deriving eq, ord] -type t = logical_constraint +module Ord = struct + type t = logical_constraint -let equal = equal_logical_constraint + let equal = equal_logical_constraint -let compare = compare_logical_constraint + let compare = compare_logical_constraint +end + +include Ord +module Set = Set.Make (Ord) let pp = function | T it -> IT.pp it diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index a42957524..f53202621 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -146,7 +146,7 @@ module General = struct let@ model = model () in let@ global = get_global () in let@ all_cs = get_cs () in - let () = assert (not (Context.LCSet.mem c all_cs)) in + let () = assert (not (Context.LC.Set.mem c all_cs)) in debug_constraint_failure_diagnostics 6 model global simp_ctxt c; let@ () = Diagnostics.investigate model c in fail (fun ctxt -> diff --git a/backend/cn/lib/resourceTypes.ml b/backend/cn/lib/resourceTypes.ml index ae98ba361..1f7d8bff1 100644 --- a/backend/cn/lib/resourceTypes.ml +++ b/backend/cn/lib/resourceTypes.ml @@ -1,6 +1,5 @@ open Pp.Infix module IT = IndexTerms -module LCSet = Set.Make (LogicalConstraints) type init = | Init diff --git a/backend/cn/lib/resourceTypes.mli b/backend/cn/lib/resourceTypes.mli index e3cea8ab7..3dd58e964 100644 --- a/backend/cn/lib/resourceTypes.mli +++ b/backend/cn/lib/resourceTypes.mli @@ -1,6 +1,3 @@ -module LCSet : - Set.S with type elt = LogicalConstraints.t and type t = Set.Make(LogicalConstraints).t - type init = | Init | Uninit diff --git a/backend/cn/lib/resources.ml b/backend/cn/lib/resources.ml index 9d45ea9e2..2e648b0c6 100644 --- a/backend/cn/lib/resources.ml +++ b/backend/cn/lib/resources.ml @@ -1,7 +1,6 @@ module CF = Cerb_frontend module IT = IndexTerms module LC = LogicalConstraints -module LCSet = Set.Make (LC) open ResourceTypes type oargs = O of IT.t diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index 56ac5de22..797cabbc3 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -15,7 +15,6 @@ end module ITPairMap = Map.Make (ITPair) module ITSet = Set.Make (IT) -module LCSet = Set.Make (LC) type simp_ctxt = { global : Global.t; diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index a5623f778..1b889895a 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -27,7 +27,6 @@ module IntWithHash = struct end module Int_Table = Hashtbl.Make (IntWithHash) -module LCSet = Set.Make (LC) module CTypeMap = Map.Make (Sctypes) open Global open Pp @@ -1126,7 +1125,7 @@ let translate_goal solver assumptions lc = translate_term solver new_asmp :: acc | _ -> acc in - LCSet.fold check_asmp assumptions acc0 + LC.Set.fold check_asmp assumptions acc0 in { instantiated with extra = List.fold_left add_asmps [] instantiated.qs } diff --git a/backend/cn/lib/solver.mli b/backend/cn/lib/solver.mli index 5537da5fe..d63d4ffff 100644 --- a/backend/cn/lib/solver.mli +++ b/backend/cn/lib/solver.mli @@ -45,7 +45,7 @@ val provable : loc:Locations.t -> solver:solver -> global:Global.t -> - assumptions:Context.LCSet.t -> + assumptions:Context.LC.Set.t -> simp_ctxt:Simplify.simp_ctxt -> LogicalConstraints.t -> [> `True | `False ] @@ -74,7 +74,7 @@ val debug_solver_to_string : solver -> unit val debug_solver_query : solver -> Global.t -> - Context.LCSet.t -> + Context.LC.Set.t -> IndexTerms.t list -> LogicalConstraints.t -> unit diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 23d72dea4..b2b41f44d 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -415,7 +415,7 @@ let init_solver () = modify (fun s -> let c = s.typing_context in let solver = Solver.make c.global in - LCSet.iter (Solver.add_assumption solver c.global) c.constraints; + LC.Set.iter (Solver.add_assumption solver c.global) c.constraints; { s with solver = Some solver }) diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 2ed6fb4fd..100ac51eb 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -34,7 +34,7 @@ val print_with_ctxt : (Context.t -> unit) -> unit m val get_global : unit -> Global.t m -val get_cs : unit -> Context.LCSet.t m +val get_cs : unit -> Context.LC.Set.t m val simp_ctxt : unit -> Simplify.simp_ctxt m From d33de8caa8bdb182f5cd202630403a715c234455 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 16:32:02 +0000 Subject: [PATCH 092/148] Put records in modules in resourceTypes --- backend/cn/lib/check.ml | 6 +- backend/cn/lib/cnprog.ml | 16 +- backend/cn/lib/compile.ml | 6 +- backend/cn/lib/explain.ml | 8 +- backend/cn/lib/interval.ml | 2 +- backend/cn/lib/interval.mli | 2 +- backend/cn/lib/pack.ml | 4 +- backend/cn/lib/resourceInference.ml | 12 +- backend/cn/lib/resourceInference.mli | 8 +- backend/cn/lib/resourceTypes.ml | 273 +++++++++---------- backend/cn/lib/resourceTypes.mli | 96 ++++--- backend/cn/lib/resources.ml | 11 +- backend/cn/lib/simplify.ml | 56 ++-- backend/cn/lib/testGeneration/genAnalysis.ml | 4 +- backend/cn/lib/typeErrors.ml | 4 +- backend/cn/lib/typing.ml | 6 +- backend/cn/lib/typing.mli | 4 +- backend/cn/lib/wellTyped.ml | 2 +- 18 files changed, 263 insertions(+), 257 deletions(-) diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index a11921ed3..9e42d7de7 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -1271,7 +1271,7 @@ let add_trace_information _labels annots = return () -let bytes_qpred sym size pointer init : RET.qpredicate_type = +let bytes_qpred sym size pointer init : RET.QPredicate.t = let here = Locations.other __FUNCTION__ in let bt' = WellTyped.quantifier_bt in { q = (sym, bt'); @@ -1300,7 +1300,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = debug 3 (lazy (item "expr" (group (Pp_mucore.pp_expr e)))); debug 3 (lazy (item "ctxt" (Context.pp ctxt)))) in - let bytes_qpred sym ct pointer init : RET.qpredicate_type = + let bytes_qpred sym ct pointer init : RET.QPredicate.t = let here = Locations.other __FUNCTION__ in bytes_qpred sym (sizeOf_ ct here) pointer init in @@ -1805,7 +1805,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in aux es [] [] | CN_progs (_, cn_progs) -> - let bytes_pred ct pointer init : RET.predicate_type = + let bytes_pred ct pointer init : RET.Predicate.t = { name = Owned (ct, init); pointer; iargs = [] } in let bytes_constraints ~(value : IT.t) ~(byte_arr : IT.t) (ct : Sctypes.t) = diff --git a/backend/cn/lib/cnprog.ml b/backend/cn/lib/cnprog.ml index 2e36eca28..b30e7690b 100644 --- a/backend/cn/lib/cnprog.ml +++ b/backend/cn/lib/cnprog.ml @@ -12,8 +12,8 @@ type have_show = type extract = Id.t list * (Sym.t, Sctypes.t) CF.Cn.cn_to_extract * IndexTerms.t type statement = - | Pack_unpack of CF.Cn.pack_unpack * ResourceTypes.predicate_type - | To_from_bytes of CF.Cn.to_from * ResourceTypes.predicate_type + | Pack_unpack of CF.Cn.pack_unpack * ResourceTypes.Predicate.t + | To_from_bytes of CF.Cn.to_from * ResourceTypes.Predicate.t | Have of LogicalConstraints.t | Instantiate of (Sym.t, Sctypes.t) CF.Cn.cn_to_instantiate * IndexTerms.t | Split_case of LogicalConstraints.t @@ -42,9 +42,9 @@ let rec subst substitution = function let stmt = match stmt with | Pack_unpack (pack_unpack, pt) -> - Pack_unpack (pack_unpack, RET.subst_predicate_type substitution pt) + Pack_unpack (pack_unpack, RET.Predicate.subst substitution pt) | To_from_bytes (to_from, pt) -> - To_from_bytes (to_from, RET.subst_predicate_type substitution pt) + To_from_bytes (to_from, RET.Predicate.subst substitution pt) | Have lc -> Have (LC.subst substitution lc) | Instantiate (o_s, it) -> (* o_s is not a (option) binder *) @@ -105,13 +105,13 @@ let dtree_of_statement = let open Cerb_frontend.Pp_ast in function | Pack_unpack (Pack, pred) -> - Dnode (pp_ctor "Pack", [ ResourceTypes.dtree_of_predicate_type pred ]) + Dnode (pp_ctor "Pack", [ ResourceTypes.Predicate.dtree pred ]) | Pack_unpack (Unpack, pred) -> - Dnode (pp_ctor "Unpack", [ ResourceTypes.dtree_of_predicate_type pred ]) + Dnode (pp_ctor "Unpack", [ ResourceTypes.Predicate.dtree pred ]) | To_from_bytes (To, pred) -> - Dnode (pp_ctor "To_bytes", [ ResourceTypes.dtree_of_predicate_type pred ]) + Dnode (pp_ctor "To_bytes", [ ResourceTypes.Predicate.dtree pred ]) | To_from_bytes (From, pred) -> - Dnode (pp_ctor "From_bytes", [ ResourceTypes.dtree_of_predicate_type pred ]) + Dnode (pp_ctor "From_bytes", [ ResourceTypes.Predicate.dtree pred ]) | Have lc -> Dnode (pp_ctor "Have", [ LC.dtree lc ]) | Instantiate (to_instantiate, it) -> Dnode (pp_ctor "Instantiate", [ dtree_of_to_instantiate to_instantiate; IT.dtree it ]) diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 602bb9a0a..e40740929 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -1053,11 +1053,11 @@ module EffectfulTranslation = struct (* we don't take Resources.owned_oargs here because we want to maintain the C-type information *) let oargs_ty = Memory.sbt_of_sct scty in - return (Owned (scty, Init), oargs_ty) + return (RET.Owned (scty, Init), oargs_ty) | CN_block oty -> let@ scty = infer_scty "Block" oty in let oargs_ty = Memory.sbt_of_sct scty in - return (Owned (scty, Uninit), oargs_ty) + return (RET.Owned (scty, Uninit), oargs_ty) | CN_named pred -> let@ pred_sig = match lookup_predicate pred env with @@ -1066,7 +1066,7 @@ module EffectfulTranslation = struct | Some pred_sig -> return pred_sig in let output_bt = pred_sig.pred_output in - return (PName pred, SBT.inj output_bt) + return (RET.PName pred, SBT.inj output_bt) in return (pname, ptr_expr, iargs, oargs_ty) diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index 120e4ac8d..3dea212eb 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -36,7 +36,7 @@ type log = log_entry list (* most recent first *) let clause_has_resource req c = let open LogicalArgumentTypes in let rec f = function - | Resource ((_, (r, _)), _, c) -> RET.same_predicate_name req r || f c + | Resource ((_, (r, _)), _, c) -> RET.same_name req r || f c | Constraint (_, _, c) -> f c | Define (_, _, c) -> f c | I _ -> false @@ -299,13 +299,13 @@ let state ctxt log model_with_q extras = match extras.request with | None -> ([], get_rs ctxt) | Some req -> - List.partition (fun r -> RET.same_predicate_name req (RE.request r)) (get_rs ctxt) + List.partition (fun r -> RET.same_name req (RE.request r)) (get_rs ctxt) in let interesting_diff_res, uninteresting_diff_res = List.partition (fun (ret, _o) -> match ret with - | P ret when equal_predicate_name ret.name ResourceTypes.alloc -> false + | P ret when RET.equal_name ret.name RET.Predicate.alloc -> false | _ -> true) diff_res in @@ -359,7 +359,7 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra | None -> [] | Some req -> let open ResourcePredicates in - (match predicate_name req with + (match RET.get_name req with | Owned _ -> [] | PName pname -> let doc_clause (_name, c) = diff --git a/backend/cn/lib/interval.ml b/backend/cn/lib/interval.ml index b5b628370..bb2610f73 100644 --- a/backend/cn/lib/interval.ml +++ b/backend/cn/lib/interval.ml @@ -244,7 +244,7 @@ module Solver = struct | _ -> None - let simp_rt eval (rt : RT.resource_type) : RT.resource_type = + let simp_rt eval (rt : RT.t) : RT.t = match rt with | RT.P _ -> rt | RT.Q qpred -> diff --git a/backend/cn/lib/interval.mli b/backend/cn/lib/interval.mli index 569671875..b877ef2ff 100644 --- a/backend/cn/lib/interval.mli +++ b/backend/cn/lib/interval.mli @@ -101,5 +101,5 @@ module Solver : sig module RT = ResourceTypes (** Try to simplify a resource type *) - val simp_rt : (IT.t -> IT.t option) -> RT.resource_type -> RT.resource_type + val simp_rt : (IT.t -> IT.t option) -> RT.t -> RT.t end diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index db7e7e623..cc47b727a 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -150,7 +150,7 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O (* in *) match ret with | Q ret - when equal_predicate_name predicate_name ret.name + when ResourceTypes.equal_name predicate_name ret.name && BT.equal (IT.bt index) (snd ret.q) -> let su = IT.make_subst [ (fst ret.q, index) ] in let index_permission = IT.subst su ret.permission in @@ -188,7 +188,7 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O (* (lazy (IndexTerms.pp_with_eval eval_f index_permission)); *) None) (* | Q qret -> *) - (* if not (equal_predicate_name predicate_name qret.name) *) + (* if not (ResourceTypes.equal_name predicate_name qret.name) *) (* then () *) (* (\* tmsg "not extracting, predicate name differs" *\) *) (* (\* (lazy (ResourceTypes.pp_predicate_name predicate_name)) *\) *) diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index f53202621..84d8fa3a8 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -160,8 +160,8 @@ module General = struct (* TODO: check that oargs are in the same order? *) - let rec predicate_request loc (uiinfo : uiinfo) (requested : RET.predicate_type) - : ((RET.predicate_type * Resources.oargs) * int list) option m + let rec predicate_request loc (uiinfo : uiinfo) (requested : RET.Predicate.t) + : ((RET.Predicate.t * Resources.oargs) * int list) option m = Pp.(debug 7 (lazy (item __FUNCTION__ (RET.pp (P requested))))); let start_timing = Pp.time_log_start __FUNCTION__ "" in @@ -251,7 +251,7 @@ module General = struct return res - and qpredicate_request_aux loc uiinfo (requested : RET.qpredicate_type) = + and qpredicate_request_aux loc uiinfo (requested : RET.QPredicate.t) = Pp.(debug 7 (lazy (item __FUNCTION__ (RET.pp (Q requested))))); let@ provable = provable loc in let@ simp_ctxt = simp_ctxt () in @@ -285,7 +285,7 @@ module General = struct when RET.subsumed requested.name p'.name && IT.equal step p'.step && BaseTypes.equal (snd requested.q) (snd p'.q) -> - let p' = RET.alpha_rename_qpredicate_type_ (fst requested.q) p' in + let p' = RET.QPredicate.alpha_rename_ (fst requested.q) p' in let here = Locations.other __FUNCTION__ in let pmatch = (* Work-around for https://github.com/Z3Prover/z3/issues/7352 *) @@ -393,7 +393,7 @@ module General = struct return None - and qpredicate_request loc uiinfo (requested : RET.qpredicate_type) = + and qpredicate_request loc uiinfo (requested : RET.QPredicate.t) = let@ o_oarg = qpredicate_request_aux loc uiinfo requested in let@ oarg_item_bt = WellTyped.oarg_bt_of_pred loc requested.name in match o_oarg with @@ -401,7 +401,7 @@ module General = struct | Some (oarg, rw_time) -> let@ oarg = cases_to_map loc uiinfo (snd requested.q) oarg_item_bt oarg in let r = - RET. + RET.QPredicate. { name = requested.name; pointer = requested.pointer; q = requested.q; diff --git a/backend/cn/lib/resourceInference.mli b/backend/cn/lib/resourceInference.mli index 395507afb..2d6db0116 100644 --- a/backend/cn/lib/resourceInference.mli +++ b/backend/cn/lib/resourceInference.mli @@ -28,12 +28,12 @@ module Special : sig val predicate_request : Locations.t -> TypeErrors.situation -> - ResourceTypes.predicate_type * (Locations.t * string) option -> - ((ResourceTypes.predicate_type * Resources.oargs) * int list) Typing.m + ResourceTypes.Predicate.t * (Locations.t * string) option -> + ((ResourceTypes.Predicate.t * Resources.oargs) * int list) Typing.m val qpredicate_request : Locations.t -> TypeErrors.situation -> - ResourceTypes.qpredicate_type * (Locations.t * string) option -> - ((ResourceTypes.qpredicate_type * Resources.oargs) * int list) Typing.m + ResourceTypes.QPredicate.t * (Locations.t * string) option -> + ((ResourceTypes.QPredicate.t * Resources.oargs) * int list) Typing.m end diff --git a/backend/cn/lib/resourceTypes.ml b/backend/cn/lib/resourceTypes.ml index 1f7d8bff1..27c41e3bd 100644 --- a/backend/cn/lib/resourceTypes.ml +++ b/backend/cn/lib/resourceTypes.ml @@ -1,141 +1,172 @@ open Pp.Infix module IT = IndexTerms +(* TODO move this? *) +let pp_maybe_oargs = function None -> Pp.empty | Some oargs -> Pp.parens (IT.pp oargs) + type init = | Init | Uninit [@@deriving eq, ord] -type predicate_name = +let pp_init = function Init -> !^"Init" | Uninit -> !^"Uninit" + +type name = | Owned of Sctypes.t * init | PName of Sym.t [@@deriving eq, ord] -let alloc = PName Alloc.Predicate.sym - -let pp_init = function Init -> !^"Init" | Uninit -> !^"Uninit" - -let pp_predicate_name = function +let pp_name = function | Owned (ct, Init) -> !^"Owned" ^^ Pp.angles (Sctypes.pp ct) | Owned (ct, Uninit) -> !^"Block" ^^ Pp.angles (Sctypes.pp ct) | PName pn -> Sym.pp pn -type predicate_type = - { name : predicate_name; - pointer : IT.t; (* I *) - iargs : IT.t list (* I *) - } -[@@deriving eq, ord] +let dtree_of_name = + let open Cerb_frontend.Pp_ast in + function + | Owned (ty, init) -> + Dleaf (!^"Owned" ^^ Pp.angles (Sctypes.pp ty ^^ Pp.comma ^^ pp_init init)) + | PName s -> Dleaf (Sym.pp s) -let make_alloc pointer = { name = alloc; pointer; iargs = [] } - -type qpredicate_type = - { name : predicate_name; - pointer : IT.t; (* I *) - q : Sym.t * BaseTypes.t; - q_loc : Locations.t; [@equal fun _ _ -> true] [@compare fun _ _ -> 0] - step : IT.t; - permission : IT.t; (* I, function of q *) - iargs : IT.t list (* I, function of q *) - } -[@@deriving eq, ord] let subsumed p1 p2 = (* p1 subsumed by p2 *) - equal_predicate_name p1 p2 + equal_name p1 p2 || match (p1, p2) with | Owned (ct, Uninit), Owned (ct', Init) when Sctypes.equal ct ct' -> true | _ -> false -type resource_type = - | P of predicate_type - | Q of qpredicate_type +module Predicate = struct + let alloc = PName Alloc.Predicate.sym + + type t = + { name : name; + pointer : IT.t; (* I *) + iargs : IT.t list (* I *) + } + [@@deriving eq, ord] + + let pp_aux (p : t) oargs = + let args = List.map IT.pp (p.pointer :: p.iargs) in + Pp.c_app (pp_name p.name) args ^^ pp_maybe_oargs oargs + + + let subst substitution (p : t) = + { name = p.name; + pointer = IT.subst substitution p.pointer; + iargs = List.map (IT.subst substitution) p.iargs + } + + + let dtree (pred : t) = + let open Cerb_frontend.Pp_ast in + Dnode + ( pp_ctor "pred", + dtree_of_name pred.name :: IT.dtree pred.pointer :: List.map IT.dtree pred.iargs + ) +end + +let make_alloc pointer = Predicate.{ name = alloc; pointer; iargs = [] } + +module QPredicate = struct + type t = + { name : name; + pointer : IT.t; (* I *) + q : Sym.t * BaseTypes.t; + q_loc : Locations.t; [@equal fun _ _ -> true] [@compare fun _ _ -> 0] + step : IT.t; + permission : IT.t; (* I, function of q *) + iargs : IT.t list (* I, function of q *) + } + [@@deriving eq, ord] + + let pp_aux (p : t) oargs = + let open Pp in + (* ISD: this is `p + i * step` but that's "wrong" in a couple of ways: + - we are not using the correct precedences for `p` and `step` + - in C pointer arithmetic takes account of the types, but here + we seem to be doing it at the byte level. Would `step` ever + differ from the size of elements that `p` points to? + - perhaps print as `&p[i]` or `&p[j + i]` + *) + let pointer = + IT.pp p.pointer ^^^ plus ^^^ Sym.pp (fst p.q) ^^^ star ^^^ IT.pp p.step + in + let args = pointer :: List.map IT.pp p.iargs in + !^"each" + ^^ parens (BaseTypes.pp (snd p.q) ^^^ Sym.pp (fst p.q) ^^ semi ^^^ IT.pp p.permission) + ^/^ braces (c_app (pp_name p.name) args) + ^^ pp_maybe_oargs oargs + + + let alpha_rename_ (q' : Sym.t) (qp : t) = + let subst = IT.make_rename ~from:(fst qp.q) ~to_:q' in + { name = qp.name; + pointer = qp.pointer; + q = (q', snd qp.q); + q_loc = qp.q_loc; + step = qp.step; + permission = IT.subst subst qp.permission; + iargs = List.map (IT.subst subst) qp.iargs + } + + + let alpha_rename qp = alpha_rename_ (Sym.fresh_same (fst qp.q)) qp + + let subst substitution (qp : t) = + let qp = + if Sym.Set.mem (fst qp.q) substitution.Subst.relevant then + alpha_rename qp + else + qp + in + { name = qp.name; + pointer = IT.subst substitution qp.pointer; + q = qp.q; + q_loc = qp.q_loc; + step = IT.subst substitution qp.step; + permission = IT.subst substitution qp.permission; + iargs = List.map (IT.subst substitution) qp.iargs + } + + + let dtree (qpred : t) = + let open Cerb_frontend.Pp_ast in + Dnode + ( pp_ctor "qpred", + Dleaf (Pp.parens (Pp.typ (Sym.pp (fst qpred.q)) (BaseTypes.pp (snd qpred.q)))) + :: IT.dtree qpred.step + :: IT.dtree qpred.permission + :: dtree_of_name qpred.name + :: IT.dtree qpred.pointer + :: List.map IT.dtree qpred.iargs ) +end + +type t = + | P of Predicate.t + | Q of QPredicate.t [@@deriving eq, ord] -type t = resource_type - -let predicate_name = function P p -> p.name | Q p -> p.name - -let pp_maybe_oargs = function None -> Pp.empty | Some oargs -> Pp.parens (IT.pp oargs) - -let pp_predicate_type_aux (p : predicate_type) oargs = - let args = List.map IT.pp (p.pointer :: p.iargs) in - Pp.c_app (pp_predicate_name p.name) args ^^ pp_maybe_oargs oargs - - -let pp_qpredicate_type_aux (p : qpredicate_type) oargs = - let open Pp in - (* ISD: this is `p + i * step` but that's "wrong" in a couple of ways: - - we are not using the correct precedences for `p` and `step` - - in C pointer arithmetic takes account of the types, but here - we seem to be doing it at the byte level. Would `step` ever - differ from the size of elements that `p` points to? - - perhaps print as `&p[i]` or `&p[j + i]` - *) - let pointer = IT.pp p.pointer ^^^ plus ^^^ Sym.pp (fst p.q) ^^^ star ^^^ IT.pp p.step in - let args = pointer :: List.map IT.pp p.iargs in - !^"each" - ^^ parens (BaseTypes.pp (snd p.q) ^^^ Sym.pp (fst p.q) ^^ semi ^^^ IT.pp p.permission) - ^/^ braces (c_app (pp_predicate_name p.name) args) - ^^ pp_maybe_oargs oargs +let get_name = function P p -> p.name | Q p -> p.name +(* resources of the same type as a request, such that the resource coult potentially be + used to fulfil the request *) +let same_name r1 r2 = equal_name (get_name r1) (get_name r2) let pp_aux r o = - match r with P p -> pp_predicate_type_aux p o | Q qp -> pp_qpredicate_type_aux qp o + match r with P p -> Predicate.pp_aux p o | Q qp -> QPredicate.pp_aux qp o let pp r = pp_aux r None -let equal = equal_resource_type - let json re : Yojson.Safe.t = `String (Pp.plain (pp re)) -let alpha_rename_qpredicate_type_ (q' : Sym.t) (qp : qpredicate_type) = - let subst = IT.make_rename ~from:(fst qp.q) ~to_:q' in - { name = qp.name; - pointer = qp.pointer; - q = (q', snd qp.q); - q_loc = qp.q_loc; - step = qp.step; - permission = IT.subst subst qp.permission; - iargs = List.map (IT.subst subst) qp.iargs - } - - -let alpha_rename_qpredicate_type qp = - alpha_rename_qpredicate_type_ (Sym.fresh_same (fst qp.q)) qp - - -let subst_predicate_type substitution (p : predicate_type) = - { name = p.name; - pointer = IT.subst substitution p.pointer; - iargs = List.map (IT.subst substitution) p.iargs - } - - -let subst_qpredicate_type substitution (qp : qpredicate_type) = - let qp = - if Sym.Set.mem (fst qp.q) substitution.Subst.relevant then - alpha_rename_qpredicate_type qp - else - qp - in - { name = qp.name; - pointer = IT.subst substitution qp.pointer; - q = qp.q; - q_loc = qp.q_loc; - step = IT.subst substitution qp.step; - permission = IT.subst substitution qp.permission; - iargs = List.map (IT.subst substitution) qp.iargs - } - - let subst (substitution : _ Subst.t) = function - | P p -> P (subst_predicate_type substitution p) - | Q qp -> Q (subst_qpredicate_type substitution qp) + | P p -> P (Predicate.subst substitution p) + | Q qp -> Q (QPredicate.subst substitution qp) let free_vars_bts = function @@ -157,51 +188,15 @@ let free_vars = function (Sym.Set.remove (fst p.q) (IT.free_vars_list (p.permission :: p.iargs))) -(* resources of the same type as a request, such that the resource coult potentially be - used to fulfil the request *) -let same_predicate_name r1 r2 = - equal_predicate_name (predicate_name r1) (predicate_name r2) - - let alpha_equivalent r1 r2 = match (r1, r2) with - | P _, P _ -> equal_resource_type r1 r2 + | P _, P _ -> equal r1 r2 | Q x, Q y -> - let y2 = alpha_rename_qpredicate_type_ (fst x.q) y in - equal_resource_type (Q x) (Q y2) + let y2 = QPredicate.alpha_rename_ (fst x.q) y in + equal (Q x) (Q y2) | _ -> false let steps_constant = function Q qp -> Option.is_some (IT.is_const qp.step) | _ -> true -open Cerb_frontend.Pp_ast -open Pp - -let dtree_of_predicate_name = function - | Owned (ty, init) -> - Dleaf (!^"Owned" ^^ angles (Sctypes.pp ty ^^ comma ^^ pp_init init)) - | PName s -> Dleaf (Sym.pp s) - - -let dtree_of_predicate_type (pred : predicate_type) = - Dnode - ( pp_ctor "pred", - dtree_of_predicate_name pred.name - :: IT.dtree pred.pointer - :: List.map IT.dtree pred.iargs ) - - -let dtree_of_qpredicate_type (pred : qpredicate_type) = - Dnode - ( pp_ctor "qpred", - Dleaf (Pp.parens (Pp.typ (Sym.pp (fst pred.q)) (BaseTypes.pp (snd pred.q)))) - :: IT.dtree pred.step - :: IT.dtree pred.permission - :: dtree_of_predicate_name pred.name - :: IT.dtree pred.pointer - :: List.map IT.dtree pred.iargs ) - - -let dtree = function - | P pred -> dtree_of_predicate_type pred - | Q pred -> dtree_of_qpredicate_type pred +let dtree = function P pred -> Predicate.dtree pred | Q qpred -> QPredicate.dtree qpred diff --git a/backend/cn/lib/resourceTypes.mli b/backend/cn/lib/resourceTypes.mli index 3dd58e964..78c7377c9 100644 --- a/backend/cn/lib/resourceTypes.mli +++ b/backend/cn/lib/resourceTypes.mli @@ -2,75 +2,81 @@ type init = | Init | Uninit -type predicate_name = +val pp_init : init -> Pp.document + +type name = | Owned of Sctypes.t * init | PName of Sym.t [@@deriving eq] -val alloc : predicate_name +val pp_name : name -> Pp.document + +val dtree_of_name : name -> Cerb_frontend.Pp_ast.doc_tree + +val subsumed : name -> name -> bool + +module Predicate : sig + type t = + { name : name; + pointer : IndexTerms.t; + iargs : IndexTerms.t list + } -val pp_predicate_name : predicate_name -> Pp.document + val alloc : name -type predicate_type = - { name : predicate_name; - pointer : IndexTerms.t; - iargs : IndexTerms.t list - } + val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t -val make_alloc : IndexTerms.t -> predicate_type + val dtree : t -> Cerb_frontend.Pp_ast.doc_tree +end -type qpredicate_type = - { name : predicate_name; - pointer : IndexTerms.t; - q : Sym.t * BaseTypes.t; - q_loc : Locations.t; - step : IndexTerms.t; - permission : IndexTerms.t; - iargs : IndexTerms.t list - } +val make_alloc : IndexTerms.t -> Predicate.t -val subsumed : predicate_name -> predicate_name -> bool +module QPredicate : sig + type t = + { name : name; + pointer : IndexTerms.t; + q : Sym.t * BaseTypes.t; + q_loc : Locations.t; + step : IndexTerms.t; + permission : IndexTerms.t; + iargs : IndexTerms.t list + } -type resource_type = - | P of predicate_type - | Q of qpredicate_type + val alpha_rename_ : Sym.t -> t -> t -type t = resource_type + val alpha_rename : t -> t -val predicate_name : resource_type -> predicate_name + val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t -val pp_aux : resource_type -> 'a Terms.annot option -> Pp.document + val dtree : t -> Cerb_frontend.Pp_ast.doc_tree +end -val pp : resource_type -> Pp.document +type t = + | P of Predicate.t + | Q of QPredicate.t -val equal : resource_type -> resource_type -> bool +val equal : t -> t -> bool -val json : resource_type -> Yojson.Safe.t +val compare : t -> t -> int -val alpha_rename_qpredicate_type_ : Sym.t -> qpredicate_type -> qpredicate_type +val get_name : t -> name -val alpha_rename_qpredicate_type : qpredicate_type -> qpredicate_type +val same_name : t -> t -> bool -val subst_predicate_type - : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> - predicate_type -> - predicate_type +val pp_aux : t -> 'a Terms.annot option -> Pp.document -val subst - : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> - resource_type -> - resource_type +val pp : t -> Pp.document -val free_vars_bts : resource_type -> BaseTypes.t Sym.Map.t +val json : t -> Yojson.Safe.t -val free_vars : resource_type -> Sym.Set.t +val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t -val same_predicate_name : resource_type -> resource_type -> bool +val free_vars_bts : t -> IndexTerms.BT.t Sym.Map.t -val alpha_equivalent : resource_type -> resource_type -> bool +val free_vars : t -> Sym.Set.t -val steps_constant : resource_type -> bool +val alpha_equivalent : t -> t -> bool -val dtree_of_predicate_type : predicate_type -> Cerb_frontend.Pp_ast.doc_tree +val steps_constant : t -> bool -val dtree : resource_type -> Cerb_frontend.Pp_ast.doc_tree +val dtree : t -> Cerb_frontend.Pp_ast.doc_tree diff --git a/backend/cn/lib/resources.ml b/backend/cn/lib/resources.ml index 2e648b0c6..2180fd472 100644 --- a/backend/cn/lib/resources.ml +++ b/backend/cn/lib/resources.ml @@ -1,13 +1,13 @@ module CF = Cerb_frontend module IT = IndexTerms module LC = LogicalConstraints -open ResourceTypes +module RT = ResourceTypes type oargs = O of IT.t let pp_oargs (O t) = IT.pp t -type resource = resource_type * oargs +type resource = RT.t * oargs type t = resource @@ -36,7 +36,7 @@ let range_size ct = let upper_bound addr ct loc = IT.add_ (addr, range_size ct) loc (* assumption: the resource is owned *) -let derived_lc1 (resource, O oarg) = +let derived_lc1 ((resource : RT.t), O oarg) = let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in match resource with | P { name = Owned (ct, _); pointer; iargs = _ } -> @@ -51,7 +51,8 @@ let derived_lc1 (resource, O oarg) = [] in [ IT.hasAllocId_ pointer here; IT.(le_ (addr, upper) here) ] @ alloc_bounds - | P { name; pointer; iargs = [] } when !IT.use_vip && equal_predicate_name name alloc -> + | P { name; pointer; iargs = [] } + when !IT.use_vip && RT.(equal_name name Predicate.alloc) -> let module H = Alloc.History in let lookup = H.lookup_ptr pointer here in let H.{ base; size } = H.split lookup here in @@ -62,7 +63,7 @@ let derived_lc1 (resource, O oarg) = (* assumption: both resources are owned at the same *) (* todo, depending on how much we need *) -let derived_lc2 (resource, _) (resource', _) = +let derived_lc2 ((resource : RT.t), _) ((resource' : RT.t), _) = match (resource, resource') with | ( P { name = Owned (ct1, _); pointer = p1; iargs = _ }, P { name = Owned (ct2, _); pointer = p2; iargs = _ } ) -> diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index 797cabbc3..c3ec31c95 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -630,30 +630,34 @@ module LogicalConstraints = struct end module ResourceTypes = struct - open IndexTerms - open ResourceTypes - - let simp_predicate_type simp_ctxt (p : predicate_type) = - { name = p.name; - pointer = simp simp_ctxt p.pointer; - iargs = List.map (simp simp_ctxt) p.iargs - } - - - let simp_qpredicate_type simp_ctxt (qp : qpredicate_type) = - let qp = alpha_rename_qpredicate_type qp in - let permission = simp_flatten simp_ctxt qp.permission in - { name = qp.name; - pointer = simp simp_ctxt qp.pointer; - q = qp.q; - q_loc = qp.q_loc; - step = simp simp_ctxt qp.step; - permission = and_ permission (IT.loc qp.permission); - iargs = List.map (simp simp_ctxt) qp.iargs - } - - - let simp simp_ctxt = function - | P p -> P (simp_predicate_type simp_ctxt p) - | Q qp -> Q (simp_qpredicate_type simp_ctxt qp) + module Predicate = struct + open ResourceTypes.Predicate + + let simp simp_ctxt (p : t) = + { name = p.name; + pointer = IndexTerms.simp simp_ctxt p.pointer; + iargs = List.map (IndexTerms.simp simp_ctxt) p.iargs + } + end + + module QPredicate = struct + open ResourceTypes.QPredicate + + let simp simp_ctxt (qp : t) = + let qp = alpha_rename qp in + let permission = IndexTerms.simp_flatten simp_ctxt qp.permission in + ResourceTypes.QPredicate. + { name = qp.name; + pointer = IndexTerms.simp simp_ctxt qp.pointer; + q = qp.q; + q_loc = qp.q_loc; + step = IndexTerms.simp simp_ctxt qp.step; + permission = and_ permission (IT.loc qp.permission); + iargs = List.map (IndexTerms.simp simp_ctxt) qp.iargs + } + end + + let simp simp_ctxt : ResourceTypes.t -> ResourceTypes.t = function + | P p -> P (Predicate.simp simp_ctxt p) + | Q qp -> Q (QPredicate.simp simp_ctxt qp) end diff --git a/backend/cn/lib/testGeneration/genAnalysis.ml b/backend/cn/lib/testGeneration/genAnalysis.ml index 19d04a2b1..580413645 100644 --- a/backend/cn/lib/testGeneration/genAnalysis.ml +++ b/backend/cn/lib/testGeneration/genAnalysis.ml @@ -159,8 +159,8 @@ let get_recursive_preds (preds : (Sym.t * RP.definition) list) : Sym.Set.t = |> List.flatten |> List.map snd |> List.map fst - |> List.map ResourceTypes.predicate_name - |> List.filter_map (fun (n : RET.predicate_name) -> + |> List.map RET.get_name + |> List.filter_map (fun (n : RET.name) -> match n with PName name -> Some name | Owned _ -> None) |> Sym.Set.of_list in diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index 3222677d8..fa18c23b6 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -115,7 +115,7 @@ type message = (* some from Kayvan's compilePredicates module *) | First_iarg_missing | First_iarg_not_pointer of - { pname : ResourceTypes.predicate_name; + { pname : ResourceTypes.name; found_bty : BaseTypes.t } | Missing_member of Id.t @@ -319,7 +319,7 @@ let pp_message te = let short = !^"Non-pointer first input argument" in let descr = !^"the first input argument of predicate" - ^^^ Pp.squotes (ResourceTypes.pp_predicate_name pname) + ^^^ Pp.squotes (ResourceTypes.pp_name pname) ^^^ !^"must have type" ^^^ Pp.squotes BaseTypes.(pp (Loc ())) ^^^ !^"but was found with type" diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index b2b41f44d..5a50a0bac 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -13,7 +13,7 @@ type s = sym_eqs : IT.t Sym.Map.t; past_models : (Solver.model_with_q * Context.t) list; found_equalities : EqTable.table; - movable_indices : (RET.predicate_name * IT.t) list; + movable_indices : (RET.name * IT.t) list; unfold_resources_required : bool; log : Explain.log } @@ -701,7 +701,7 @@ let do_unfold_resources loc = (fun (re, i) (keep, unpack, extract) -> match Pack.unpack loc s.global provable_f2 re with | Some unpackable -> - let pname = RET.predicate_name (fst re) in + let pname = RET.get_name (fst re) in (keep, (i, pname, unpackable) :: unpack, extract) | None -> let re_reduced, extracted = @@ -725,7 +725,7 @@ let do_unfold_resources loc = let@ _, members = make_return_record loc - ("unpack_" ^ Pp.plain (RET.pp_predicate_name pname)) + ("unpack_" ^ Pp.plain (RET.pp_name pname)) (LogicalReturnTypes.binders lrt) in bind_logical_return_internal loc members lrt diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 100ac51eb..59ba2d7ca 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -171,10 +171,10 @@ val bind_return : Locations.t -> IndexTerms.t list -> ReturnTypes.t -> IndexTerm val add_movable_index : Locations.t -> (* verbose:bool -> *) - ResourceTypes.predicate_name * IndexTerms.t -> + ResourceTypes.name * IndexTerms.t -> unit m -val get_movable_indices : unit -> (ResourceTypes.predicate_name * IndexTerms.t) list m +val get_movable_indices : unit -> (ResourceTypes.name * IndexTerms.t) list m val record_action : Explain.action * Locations.t -> unit m diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index f70be7b85..94feaedd6 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -987,7 +987,7 @@ module WRET = struct let welltyped loc r = Pp.debug 22 (lazy (Pp.item "WRET: checking" (RET.pp r))); let@ spec_iargs = - match RET.predicate_name r with + match RET.get_name r with | Owned (_ct, _init) -> return [] | PName name -> let@ def = Typing.get_resource_predicate_def loc name in From 109600d3680d8d220761a87564dc2156a10e3388 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 16:35:42 +0000 Subject: [PATCH 093/148] Rename ResourceTypes to Request --- backend/cn/lib/argumentTypes.ml | 2 +- backend/cn/lib/check.ml | 20 +++---- backend/cn/lib/cn_internal_to_ail.ml | 12 ++--- backend/cn/lib/cnprog.ml | 19 ++++--- backend/cn/lib/compile.ml | 22 ++++---- backend/cn/lib/executable_spec_records.ml | 2 +- backend/cn/lib/explain.ml | 18 +++---- backend/cn/lib/explain.mli | 2 +- backend/cn/lib/interval.ml | 2 +- backend/cn/lib/interval.mli | 2 +- backend/cn/lib/lemmata.ml | 2 +- backend/cn/lib/logicalArgumentTypes.ml | 14 ++--- backend/cn/lib/logicalReturnTypes.ml | 2 +- backend/cn/lib/mucore.ml | 5 +- backend/cn/lib/mucore.mli | 7 ++- backend/cn/lib/pack.ml | 12 ++--- backend/cn/lib/pp_mucore.ml | 2 +- .../cn/lib/{resourceTypes.ml => request.ml} | 0 .../cn/lib/{resourceTypes.mli => request.mli} | 0 backend/cn/lib/resourceInference.ml | 52 +++++++++---------- backend/cn/lib/resourceInference.mli | 8 +-- backend/cn/lib/resources.ml | 10 ++-- backend/cn/lib/simplify.ml | 10 ++-- backend/cn/lib/testGeneration/genAnalysis.ml | 6 +-- backend/cn/lib/testGeneration/genCompile.ml | 6 +-- backend/cn/lib/typeErrors.ml | 10 ++-- backend/cn/lib/typing.ml | 10 ++-- backend/cn/lib/typing.mli | 4 +- backend/cn/lib/wellTyped.ml | 30 +++++------ 29 files changed, 143 insertions(+), 148 deletions(-) rename backend/cn/lib/{resourceTypes.ml => request.ml} (100%) rename backend/cn/lib/{resourceTypes.mli => request.mli} (100%) diff --git a/backend/cn/lib/argumentTypes.ml b/backend/cn/lib/argumentTypes.ml index 3b56deb29..842324d22 100644 --- a/backend/cn/lib/argumentTypes.ml +++ b/backend/cn/lib/argumentTypes.ml @@ -2,7 +2,7 @@ open Locations module BT = BaseTypes module IT = IndexTerms module LS = LogicalSorts -module RET = ResourceTypes +module Req = Request module LC = LogicalConstraints module LAT = LogicalArgumentTypes diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 9e42d7de7..db11806fd 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -1271,7 +1271,7 @@ let add_trace_information _labels annots = return () -let bytes_qpred sym size pointer init : RET.QPredicate.t = +let bytes_qpred sym size pointer init : Req.QPredicate.t = let here = Locations.other __FUNCTION__ in let bt' = WellTyped.quantifier_bt in { q = (sym, bt'); @@ -1300,7 +1300,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = debug 3 (lazy (item "expr" (group (Pp_mucore.pp_expr e)))); debug 3 (lazy (item "ctxt" (Context.pp ctxt)))) in - let bytes_qpred sym ct pointer init : RET.QPredicate.t = + let bytes_qpred sym ct pointer init : Req.QPredicate.t = let here = Locations.other __FUNCTION__ in bytes_qpred sym (sizeOf_ ct here) pointer init in @@ -1629,7 +1629,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = else return () in - let@ () = add_r loc (P (RET.make_alloc ret), O lookup) in + let@ () = add_r loc (P (Req.make_alloc ret), O lookup) in let@ () = record_action (Create ret, loc) in k ret) | CreateReadOnly (_sym1, _ct, _sym2, _prefix) -> @@ -1648,7 +1648,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = ({ name = Owned (ct, Uninit); pointer = arg; iargs = [] }, None) in let@ _ = - RI.Special.predicate_request loc (Access Kill) (RET.make_alloc arg, None) + RI.Special.predicate_request loc (Access Kill) (Req.make_alloc arg, None) in let@ () = record_action (Kill arg, loc) in k (unit_ loc)) @@ -1805,7 +1805,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in aux es [] [] | CN_progs (_, cn_progs) -> - let bytes_pred ct pointer init : RET.Predicate.t = + let bytes_pred ct pointer init : Req.Predicate.t = { name = Owned (ct, init); pointer; iargs = [] } in let bytes_constraints ~(value : IT.t) ~(byte_arr : IT.t) (ct : Sctypes.t) = @@ -1919,16 +1919,16 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = fail (fun _ -> { loc; msg = Generic !^msg }) | E_Pred (CN_owned (Some ct)) -> let@ () = WellTyped.WCT.is_ct loc ct in - return (ResourceTypes.Owned (ct, Init)) + return (Request.Owned (ct, Init)) | E_Pred (CN_block None) -> let msg = "'extract' requires a C-type annotation for 'Block'" in fail (fun _ -> { loc; msg = Generic !^msg }) | E_Pred (CN_block (Some ct)) -> let@ () = WellTyped.WCT.is_ct loc ct in - return (ResourceTypes.Owned (ct, Uninit)) + return (Request.Owned (ct, Uninit)) | E_Pred (CN_named pn) -> let@ _ = get_resource_predicate_def loc pn in - return (ResourceTypes.PName pn) + return (Request.PName pn) in let@ it = WellTyped.WIT.infer it in let@ original_rs, _ = all_resources_tagged loc in @@ -2539,8 +2539,8 @@ let memcpy_proxy_ft = let map_bt = BT.Map (q_bt, uchar_bt) in let destIn_sym, _ = IT.fresh_named map_bt "destIn" here in let srcIn_sym, srcIn = IT.fresh_named map_bt "srcIn" here in - let destRes str init = RET.Q (bytes_qpred (Sym.fresh_named str) n dest init) in - let srcRes str = RET.Q (bytes_qpred (Sym.fresh_named str) n src Init) in + let destRes str init = Req.Q (bytes_qpred (Sym.fresh_named str) n dest init) in + let srcRes str = Req.Q (bytes_qpred (Sym.fresh_named str) n src Init) in (* ensures *) let ret_sym, ret = IT.fresh_named (BT.Loc ()) "return" here in let destOut_sym, destOut = IT.fresh_named map_bt "destOut" here in diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 64eb7dcdd..b628a54bc 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -2567,7 +2567,7 @@ let cn_to_ail_resource_internal _loc = let calculate_return_type = function - | ResourceTypes.Owned (sct, _) -> + | Request.Owned (sct, _) -> ( Sctypes.to_ctype sct, BT.of_sct Memory.is_signed_integer_type Memory.size_of_integer_type sct ) | PName pname -> @@ -2590,7 +2590,7 @@ let cn_to_ail_resource_internal in (* let make_deref_expr_ e_ = A.(AilEunary (Indirection, mk_expr e_)) in *) function - | ResourceTypes.P p -> + | Request.P p -> let ctype, bt = calculate_return_type p.name in let b, s, e = cn_to_ail_expr_internal dts globals p.pointer PassBack in let enum_str = if is_pre then "GET" else "PUT" in @@ -2639,7 +2639,7 @@ let cn_to_ail_resource_internal | _ -> A.(AilSdeclaration [ (sym, Some rhs) ]) in (b @ bs, s @ ss @ [ s_decl ]) - | ResourceTypes.Q q -> + | Request.Q q -> (* Input is expr of the form: take sym = each (integer q.q; q.permission){ Owned(q.pointer + (q.q * q.step)) } @@ -3535,7 +3535,7 @@ let cn_to_ail_assume_resource_internal loc = let calculate_return_type = function - | ResourceTypes.Owned (sct, _) -> + | Request.Owned (sct, _) -> ( Sctypes.to_ctype sct, BT.of_sct Memory.is_signed_integer_type Memory.size_of_integer_type sct ) | PName pname -> @@ -3558,7 +3558,7 @@ let cn_to_ail_assume_resource_internal in (* let make_deref_expr_ e_ = A.(AilEunary (Indirection, mk_expr e_)) in *) function - | ResourceTypes.P p -> + | Request.P p -> let ctype, bt = calculate_return_type p.name in let b, s, e = cn_to_ail_expr_internal dts globals p.pointer PassBack in let rhs, bs, ss, _owned_ctype = @@ -3611,7 +3611,7 @@ let cn_to_ail_assume_resource_internal | _ -> A.(AilSdeclaration [ (sym, Some rhs) ]) in (b @ bs, s @ ss @ [ s_decl ]) - | ResourceTypes.Q q -> + | Request.Q q -> (* Input is expr of the form: take sym = each (integer q.q; q.permission){ Owned(q.pointer + (q.q * q.step)) } diff --git a/backend/cn/lib/cnprog.ml b/backend/cn/lib/cnprog.ml index b30e7690b..40b3491f0 100644 --- a/backend/cn/lib/cnprog.ml +++ b/backend/cn/lib/cnprog.ml @@ -2,7 +2,7 @@ module BT = BaseTypes module IT = IndexTerms module Loc = Locations module CF = Cerb_frontend -module RET = ResourceTypes +module Req = Request module LC = LogicalConstraints type have_show = @@ -12,8 +12,8 @@ type have_show = type extract = Id.t list * (Sym.t, Sctypes.t) CF.Cn.cn_to_extract * IndexTerms.t type statement = - | Pack_unpack of CF.Cn.pack_unpack * ResourceTypes.Predicate.t - | To_from_bytes of CF.Cn.to_from * ResourceTypes.Predicate.t + | Pack_unpack of CF.Cn.pack_unpack * Request.Predicate.t + | To_from_bytes of CF.Cn.to_from * Request.Predicate.t | Have of LogicalConstraints.t | Instantiate of (Sym.t, Sctypes.t) CF.Cn.cn_to_instantiate * IndexTerms.t | Split_case of LogicalConstraints.t @@ -42,9 +42,9 @@ let rec subst substitution = function let stmt = match stmt with | Pack_unpack (pack_unpack, pt) -> - Pack_unpack (pack_unpack, RET.Predicate.subst substitution pt) + Pack_unpack (pack_unpack, Req.Predicate.subst substitution pt) | To_from_bytes (to_from, pt) -> - To_from_bytes (to_from, RET.Predicate.subst substitution pt) + To_from_bytes (to_from, Req.Predicate.subst substitution pt) | Have lc -> Have (LC.subst substitution lc) | Instantiate (o_s, it) -> (* o_s is not a (option) binder *) @@ -104,14 +104,13 @@ let dtree_of_to_extract = let dtree_of_statement = let open Cerb_frontend.Pp_ast in function - | Pack_unpack (Pack, pred) -> - Dnode (pp_ctor "Pack", [ ResourceTypes.Predicate.dtree pred ]) + | Pack_unpack (Pack, pred) -> Dnode (pp_ctor "Pack", [ Request.Predicate.dtree pred ]) | Pack_unpack (Unpack, pred) -> - Dnode (pp_ctor "Unpack", [ ResourceTypes.Predicate.dtree pred ]) + Dnode (pp_ctor "Unpack", [ Request.Predicate.dtree pred ]) | To_from_bytes (To, pred) -> - Dnode (pp_ctor "To_bytes", [ ResourceTypes.Predicate.dtree pred ]) + Dnode (pp_ctor "To_bytes", [ Request.Predicate.dtree pred ]) | To_from_bytes (From, pred) -> - Dnode (pp_ctor "From_bytes", [ ResourceTypes.Predicate.dtree pred ]) + Dnode (pp_ctor "From_bytes", [ Request.Predicate.dtree pred ]) | Have lc -> Dnode (pp_ctor "Have", [ LC.dtree lc ]) | Instantiate (to_instantiate, it) -> Dnode (pp_ctor "Instantiate", [ dtree_of_to_instantiate to_instantiate; IT.dtree it ]) diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index e40740929..19d31cfd0 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -6,7 +6,7 @@ module IT = IndexTerms module LAT = LogicalArgumentTypes module LRT = LogicalReturnTypes module LC = LogicalConstraints -module RET = ResourceTypes +module Req = Request module Mu = Mucore module RT = ReturnTypes open Pp @@ -1013,7 +1013,7 @@ module EffectfulTranslation = struct let translate_cn_res_info res_loc loc env res args = - let open RET in + let open Req in let@ ptr_expr, iargs = match args with | [] -> fail { loc; msg = First_iarg_missing } @@ -1053,11 +1053,11 @@ module EffectfulTranslation = struct (* we don't take Resources.owned_oargs here because we want to maintain the C-type information *) let oargs_ty = Memory.sbt_of_sct scty in - return (RET.Owned (scty, Init), oargs_ty) + return (Req.Owned (scty, Init), oargs_ty) | CN_block oty -> let@ scty = infer_scty "Block" oty in let oargs_ty = Memory.sbt_of_sct scty in - return (RET.Owned (scty, Uninit), oargs_ty) + return (Req.Owned (scty, Uninit), oargs_ty) | CN_named pred -> let@ pred_sig = match lookup_predicate pred env with @@ -1066,7 +1066,7 @@ module EffectfulTranslation = struct | Some pred_sig -> return pred_sig in let output_bt = pred_sig.pred_output in - return (RET.PName pred, SBT.inj output_bt) + return (Req.PName pred, SBT.inj output_bt) in return (pname, ptr_expr, iargs, oargs_ty) @@ -1085,11 +1085,11 @@ module EffectfulTranslation = struct let owned_good _sym (res_t, _oargs_ty) = let here = Locations.other __FUNCTION__ in match res_t with - | RET.P { pointer; name = Owned (scty, _); _ } -> + | Req.P { pointer; name = Owned (scty, _); _ } -> [ ( LC.T (IT.good_ (Pointer scty, pointer) here), (here, Some "default pointer constraint") ) ] - | RET.Q { pointer; name = Owned (scty, _); _ } -> + | Req.Q { pointer; name = Owned (scty, _); _ } -> [ ( LC.T (IT.good_ (Pointer scty, pointer) here), (here, Some "default pointer constraint") ) ] @@ -1102,7 +1102,7 @@ module EffectfulTranslation = struct translate_cn_res_info res_loc pred_loc env res args in let pt = - ( RET.P + ( Req.P { name = pname; pointer = IT.Surface.proj ptr_expr; iargs = List.map IT.Surface.proj iargs @@ -1131,7 +1131,7 @@ module EffectfulTranslation = struct let@ ptr_base, step = split_pointer_linear_step pred_loc (q, bt', here) ptr_expr in let m_oargs_ty = SBT.make_map_bt bt' oargs_ty in let pt = - ( RET.Q + ( Req.Q { name = pname; q = (q, SBT.proj bt'); q_loc = here; @@ -1258,8 +1258,8 @@ let allocation_token loc addr_s = | SD_ObjectAddress obj_name -> Sym.fresh_make_uniq ("A_" ^ obj_name) | _ -> assert false in - let alloc_ret = ResourceTypes.make_alloc (IT.sym_ (addr_s, BT.Loc (), loc)) in - ((name, (ResourceTypes.P alloc_ret, Alloc.History.value_bt)), (loc, None)) + let alloc_ret = Request.make_alloc (IT.sym_ (addr_s, BT.Loc (), loc)) in + ((name, (Request.P alloc_ret, Alloc.History.value_bt)), (loc, None)) module LocalState = struct diff --git a/backend/cn/lib/executable_spec_records.ml b/backend/cn/lib/executable_spec_records.ml index 125b6208e..4dbd181ab 100644 --- a/backend/cn/lib/executable_spec_records.ml +++ b/backend/cn/lib/executable_spec_records.ml @@ -56,7 +56,7 @@ let rec add_records_to_map_from_it it = let add_records_to_map_from_resource = function - | ResourceTypes.P p -> List.iter add_records_to_map_from_it (p.pointer :: p.iargs) + | Request.P p -> List.iter add_records_to_map_from_it (p.pointer :: p.iargs) | Q q -> List.iter add_records_to_map_from_it (q.pointer :: q.step :: q.permission :: q.iargs) diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index 3dea212eb..2e41df207 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -3,7 +3,7 @@ module IT = IndexTerms module BT = BaseTypes module RE = Resources module REP = ResourcePredicates -module RET = ResourceTypes +module Req = Request module LC = LogicalConstraints module LF = LogicalFunctions module LAT = LogicalArgumentTypes @@ -12,7 +12,7 @@ module StringMap = Map.Make (String) module C = Context module Loc = Locations module S = Solver -open ResourceTypes +open Request open IndexTerms open Pp open C @@ -36,7 +36,7 @@ type log = log_entry list (* most recent first *) let clause_has_resource req c = let open LogicalArgumentTypes in let rec f = function - | Resource ((_, (r, _)), _, c) -> RET.same_name req r || f c + | Resource ((_, (r, _)), _, c) -> Req.same_name req r || f c | Constraint (_, _, c) -> f c | Define (_, _, c) -> f c | I _ -> false @@ -61,7 +61,7 @@ let relevant_predicate_clauses global name req = type state_extras = - { request : RET.t option; + { request : Req.t option; unproven_constraint : LC.t option } @@ -299,13 +299,13 @@ let state ctxt log model_with_q extras = match extras.request with | None -> ([], get_rs ctxt) | Some req -> - List.partition (fun r -> RET.same_name req (RE.request r)) (get_rs ctxt) + List.partition (fun r -> Req.same_name req (RE.request r)) (get_rs ctxt) in let interesting_diff_res, uninteresting_diff_res = List.partition (fun (ret, _o) -> match ret with - | P ret when RET.equal_name ret.name RET.Predicate.alloc -> false + | P ret when Req.equal_name ret.name Req.Predicate.alloc -> false | _ -> true) diff_res in @@ -335,7 +335,7 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra (* let req_cmp = Option.bind extras.request (Spans.spans_compare_for_pp model ctxt.global) in *) (* let req_entry req_cmp req = { *) - (* res = RET.pp req; *) + (* res = Req.pp req; *) (* res_span = Spans.pp_model_spans model ctxt.global req_cmp req *) (* } *) (* in *) @@ -345,7 +345,7 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra (* ^^ (if same then !^" - same-type" else !^"") *) (* } *) (* in *) - let req_entry ret = RET.pp ret in + let req_entry ret = Req.pp ret in let trace = let statef ctxt = state ctxt log model_with_q extras in List.rev @@ -359,7 +359,7 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra | None -> [] | Some req -> let open ResourcePredicates in - (match RET.get_name req with + (match Req.get_name req with | Owned _ -> [] | PName pname -> let doc_clause (_name, c) = diff --git a/backend/cn/lib/explain.mli b/backend/cn/lib/explain.mli index d9f419abc..ceba45947 100644 --- a/backend/cn/lib/explain.mli +++ b/backend/cn/lib/explain.mli @@ -17,7 +17,7 @@ type log = log_entry list (** Additional information about what went wrong. *) type state_extras = - { request : ResourceTypes.t option; (** Requested resource *) + { request : Request.t option; (** Requested resource *) unproven_constraint : LogicalConstraints.t option (** Unproven constraint *) } diff --git a/backend/cn/lib/interval.ml b/backend/cn/lib/interval.ml index bb2610f73..9f39ebd72 100644 --- a/backend/cn/lib/interval.ml +++ b/backend/cn/lib/interval.ml @@ -184,7 +184,7 @@ end module Solver = struct module IT = IndexTerms - module RT = ResourceTypes + module RT = Request open Terms open BaseTypes diff --git a/backend/cn/lib/interval.mli b/backend/cn/lib/interval.mli index b877ef2ff..7fec76865 100644 --- a/backend/cn/lib/interval.mli +++ b/backend/cn/lib/interval.mli @@ -98,7 +98,7 @@ end module Solver : sig module IT = IndexTerms - module RT = ResourceTypes + module RT = Request (** Try to simplify a resource type *) val simp_rt : (IT.t -> IT.t option) -> RT.t -> RT.t diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index e4e3088a2..57a68d036 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -163,7 +163,7 @@ let try_coerce_res (ftyp : AT.lemmat) = | LRT.Constraint (lc, info, t) -> LRT.Constraint (lc, info, erase_res r t) | LRT.Resource ((name, (re, bt)), ((loc, _) as info), t) -> let arg_name, arg_re = r in - if ResourceTypes.alpha_equivalent arg_re re then ( + if Request.alpha_equivalent arg_re re then ( Pp.debug 2 (lazy (Pp.item "erasing" (Sym.pp name))); LRT.subst (IT.make_subst [ (name, IT.sym_ (arg_name, bt, loc)) ]) t) else diff --git a/backend/cn/lib/logicalArgumentTypes.ml b/backend/cn/lib/logicalArgumentTypes.ml index 911e3b198..44acad2b1 100644 --- a/backend/cn/lib/logicalArgumentTypes.ml +++ b/backend/cn/lib/logicalArgumentTypes.ml @@ -2,12 +2,12 @@ open Locations module BT = BaseTypes module IT = IndexTerms module LS = LogicalSorts -module RET = ResourceTypes +module Req = Request module LC = LogicalConstraints type 'i t = | Define of (Sym.t * IT.t) * info * 'i t - | Resource of (Sym.t * (RET.t * BT.t)) * info * 'i t + | Resource of (Sym.t * (Req.t * BT.t)) * info * 'i t | Constraint of LC.t * info * 'i t | I of 'i @@ -31,7 +31,7 @@ let rec subst i_subst = let name, t = suitably_alpha_rename i_subst substitution.relevant name t in Define ((name, it), info, aux substitution t) | Resource ((name, (re, bt)), info, t) -> - let re = RET.subst substitution re in + let re = Req.subst substitution re in let name, t = suitably_alpha_rename i_subst substitution.relevant name t in let t = aux substitution t in Resource ((name, (re, bt)), info, t) @@ -70,7 +70,7 @@ let free_vars_bts i_free_vars_bts = let t_vars = Sym.Map.remove s (aux t) in union it_vars t_vars | Resource ((s, (re, _bt)), _info, t) -> - let re_vars = RET.free_vars_bts re in + let re_vars = Req.free_vars_bts re in let t_vars = Sym.Map.remove s (aux t) in union re_vars t_vars | Constraint (lc, _info, t) -> @@ -89,7 +89,7 @@ let free_vars i_free_vars = let t_vars = Sym.Set.remove s (aux t) in Sym.Set.union it_vars t_vars | Resource ((s, (re, _bt)), _info, t) -> - let re_vars = RET.free_vars re in + let re_vars = Req.free_vars re in let t_vars = Sym.Set.remove s (aux t) in Sym.Set.union re_vars t_vars | Constraint (lc, _info, t) -> @@ -127,7 +127,7 @@ let rec pp_aux i_pp = function | Define ((name, it), _info, t) -> group (!^"let" ^^^ Sym.pp name ^^^ equals ^^^ IT.pp it ^^ semi) :: pp_aux i_pp t | Resource ((name, (re, _bt)), _info, t) -> - group (!^"take" ^^^ Sym.pp name ^^^ equals ^^^ RET.pp re ^^ semi) :: pp_aux i_pp t + group (!^"take" ^^^ Sym.pp name ^^^ equals ^^^ Req.pp re ^^ semi) :: pp_aux i_pp t | Constraint (lc, _info, t) -> let op = equals ^^ rangle () in group (LC.pp lc ^^^ op) :: pp_aux i_pp t @@ -222,7 +222,7 @@ let dtree dtree_i = Dnode (pp_ctor "Define", [ Dleaf (Sym.pp s); IT.dtree it; aux t ]) | Resource ((s, (rt, bt)), _, t) -> Dnode - (pp_ctor "Resource", [ Dleaf (Sym.pp s); RET.dtree rt; Dleaf (BT.pp bt); aux t ]) + (pp_ctor "Resource", [ Dleaf (Sym.pp s); Req.dtree rt; Dleaf (BT.pp bt); aux t ]) | Constraint (lc, _, t) -> Dnode (pp_ctor "Constraint", [ LC.dtree lc; aux t ]) | I i -> Dnode (pp_ctor "I", [ dtree_i i ]) in diff --git a/backend/cn/lib/logicalReturnTypes.ml b/backend/cn/lib/logicalReturnTypes.ml index 631a44be0..3b5659b7d 100644 --- a/backend/cn/lib/logicalReturnTypes.ml +++ b/backend/cn/lib/logicalReturnTypes.ml @@ -1,6 +1,6 @@ open Locations module BT = BaseTypes -module RT = ResourceTypes +module RT = Request module IT = IndexTerms module LC = LogicalConstraints diff --git a/backend/cn/lib/mucore.ml b/backend/cn/lib/mucore.ml index e35bf48b9..b05e191af 100644 --- a/backend/cn/lib/mucore.ml +++ b/backend/cn/lib/mucore.ml @@ -322,8 +322,7 @@ type 'TY globs = type 'i arguments_l = | Define of (Sym.t * IndexTerms.t) * Locations.info * 'i arguments_l - | Resource of - (Sym.t * (ResourceTypes.t * BaseTypes.t)) * Locations.info * 'i arguments_l + | Resource of (Sym.t * (Request.t * BaseTypes.t)) * Locations.info * 'i arguments_l | Constraint of LogicalConstraints.t * Locations.info * 'i arguments_l | I of 'i @@ -352,7 +351,7 @@ let dtree_of_arguments_l dtree_i = | Resource ((s, (rt, bt)), _, t) -> Dnode ( pp_ctor "Resource", - [ Dleaf (Sym.pp s); ResourceTypes.dtree rt; Dleaf (BaseTypes.pp bt); aux t ] ) + [ Dleaf (Sym.pp s); Request.dtree rt; Dleaf (BaseTypes.pp bt); aux t ] ) | Constraint (lc, _, t) -> Dnode (pp_ctor "Constraint", [ LogicalConstraints.dtree lc; aux t ]) | I i -> Dnode (pp_ctor "I", [ dtree_i i ]) diff --git a/backend/cn/lib/mucore.mli b/backend/cn/lib/mucore.mli index ca77f4a49..03a1987f4 100644 --- a/backend/cn/lib/mucore.mli +++ b/backend/cn/lib/mucore.mli @@ -232,8 +232,7 @@ type 'TY globs = type 'i arguments_l = | Define of (Sym.t * IndexTerms.t) * Locations.info * 'i arguments_l - | Resource of - (Sym.t * (ResourceTypes.t * BaseTypes.t)) * Locations.info * 'i arguments_l + | Resource of (Sym.t * (Request.t * BaseTypes.t)) * Locations.info * 'i arguments_l | Constraint of LogicalConstraints.t * Locations.info * 'i arguments_l | I of 'i @@ -250,12 +249,12 @@ val mConstraints 'a arguments_l val mResource - : (Sym.t * (ResourceTypes.t * BaseTypes.t)) * Locations.info -> + : (Sym.t * (Request.t * BaseTypes.t)) * Locations.info -> 'a arguments_l -> 'a arguments_l val mResources - : ((Sym.t * (ResourceTypes.t * BaseTypes.t)) * Locations.info) list -> + : ((Sym.t * (Request.t * BaseTypes.t)) * Locations.info) list -> 'a arguments_l -> 'a arguments_l diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index cc47b727a..3b47992b9 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -1,5 +1,5 @@ open IndexTerms -open ResourceTypes +open Request open Resources open ResourcePredicates open Memory @@ -144,14 +144,14 @@ let unpack loc global provable (ret, O o) = let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O o) = (* let tmsg hd tail = *) (* if verb *) - (* then Pp.print stdout (Pp.item hd (ResourceTypes.pp ret ^^ Pp.hardline ^^ *) + (* then Pp.print stdout (Pp.item hd (Request.pp ret ^^ Pp.hardline ^^ *) (* Pp.string "--" ^^ Pp.hardline ^^ Lazy.force tail)) *) (* else () *) (* in *) match ret with | Q ret - when ResourceTypes.equal_name predicate_name ret.name - && BT.equal (IT.bt index) (snd ret.q) -> + when Request.equal_name predicate_name ret.name && BT.equal (IT.bt index) (snd ret.q) + -> let su = IT.make_subst [ (fst ret.q, index) ] in let index_permission = IT.subst su ret.permission in (match prove_or_model (LC.t_ index_permission) with @@ -188,10 +188,10 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O (* (lazy (IndexTerms.pp_with_eval eval_f index_permission)); *) None) (* | Q qret -> *) - (* if not (ResourceTypes.equal_name predicate_name qret.name) *) + (* if not (Request.equal_name predicate_name qret.name) *) (* then () *) (* (\* tmsg "not extracting, predicate name differs" *\) *) - (* (\* (lazy (ResourceTypes.pp_predicate_name predicate_name)) *\) *) + (* (\* (lazy (Request.pp_predicate_name predicate_name)) *\) *) (* else if not (BT.equal (IT.bt index) (snd qret.q)) *) (* then *) (* () *) diff --git a/backend/cn/lib/pp_mucore.ml b/backend/cn/lib/pp_mucore.ml index 30ffcecf7..db39e2022 100644 --- a/backend/cn/lib/pp_mucore.ml +++ b/backend/cn/lib/pp_mucore.ml @@ -656,7 +656,7 @@ module Make (Config : CONFIG) = struct Pp.parens (!^"let" ^^^ Sym.pp s ^^^ Pp.equals ^^^ IndexTerms.pp it) ^^^ pp_arguments_l ppf l | Resource ((s, (re, _bt)), _info, l) -> - Pp.parens (!^"let" ^^^ Sym.pp s ^^^ Pp.equals ^^^ ResourceTypes.pp re) + Pp.parens (!^"let" ^^^ Sym.pp s ^^^ Pp.equals ^^^ Request.pp re) ^^^ pp_arguments_l ppf l | Constraint (lc, _info, l) -> Pp.parens (LogicalConstraints.pp lc) ^^^ pp_arguments_l ppf l diff --git a/backend/cn/lib/resourceTypes.ml b/backend/cn/lib/request.ml similarity index 100% rename from backend/cn/lib/resourceTypes.ml rename to backend/cn/lib/request.ml diff --git a/backend/cn/lib/resourceTypes.mli b/backend/cn/lib/request.mli similarity index 100% rename from backend/cn/lib/resourceTypes.mli rename to backend/cn/lib/request.mli diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 84d8fa3a8..21faf27d5 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -1,6 +1,6 @@ module IT = IndexTerms module LC = LogicalConstraints -module RET = ResourceTypes +module Req = Request type oargs = Resources.oargs = O of IT.t @@ -106,7 +106,7 @@ module General = struct let module LAT = LogicalArgumentTypes in match ftyp with | LAT.Resource ((s, (resource, _bt)), info, ftyp) -> - let resource = Simplify.ResourceTypes.simp simp_ctxt resource in + let resource = Simplify.Request.simp simp_ctxt resource in let situation, request_chain = uiinfo in let step = TypeErrors. @@ -128,7 +128,7 @@ module General = struct in { loc; msg }) | Some ((re, O oargs), changed_or_deleted') -> - assert (ResourceTypes.equal re resource); + assert (Request.equal re resource); let oargs = Simplify.IndexTerms.simp simp_ctxt oargs in let changed_or_deleted = changed_or_deleted @ changed_or_deleted' in return @@ -160,10 +160,10 @@ module General = struct (* TODO: check that oargs are in the same order? *) - let rec predicate_request loc (uiinfo : uiinfo) (requested : RET.Predicate.t) - : ((RET.Predicate.t * Resources.oargs) * int list) option m + let rec predicate_request loc (uiinfo : uiinfo) (requested : Req.Predicate.t) + : ((Req.Predicate.t * Resources.oargs) * int list) option m = - Pp.(debug 7 (lazy (item __FUNCTION__ (RET.pp (P requested))))); + Pp.(debug 7 (lazy (item __FUNCTION__ (Req.pp (P requested))))); let start_timing = Pp.time_log_start __FUNCTION__ "" in let@ oarg_bt = WellTyped.oarg_bt_of_pred loc requested.name in let@ provable = provable loc in @@ -175,7 +175,7 @@ module General = struct continue else ( match re with - | RET.P p', p'_oarg when RET.subsumed requested.name p'.name -> + | Req.P p', p'_oarg when Req.subsumed requested.name p'.name -> let here = Locations.other __FUNCTION__ in let addr_iargs_eqs = IT.(eq_ ((addr_ requested.pointer) here, addr_ p'.pointer here) here) @@ -186,14 +186,14 @@ module General = struct IT.(eq_ (allocId_ requested.pointer here, allocId_ p'.pointer here) here) in let debug_failure model msg term = - Pp.debug 9 (lazy (Pp.item msg (RET.pp (fst re)))); + Pp.debug 9 (lazy (Pp.item msg (Req.pp (fst re)))); debug_constraint_failure_diagnostics 9 model global simp_ctxt (LC.T term) in (match provable (LC.T addr_iargs_match) with | `True -> (match provable (LC.T alloc_id_eq) with | `True -> - Pp.debug 9 (lazy (Pp.item "used resource" (RET.pp (fst re)))); + Pp.debug 9 (lazy (Pp.item "used resource" (Req.pp (fst re)))); (Deleted, (false, p'_oarg)) | `False -> debug_failure @@ -243,7 +243,7 @@ module General = struct in return (Some ((requested, O o), changed_or_deleted)) | None -> - let req_pp = lazy (RET.pp (P requested)) in + let req_pp = lazy (Req.pp (P requested)) in Pp.debug 9 (Lazy.map (Pp.item "no pack rule for resource, failing") req_pp); return None) in @@ -251,8 +251,8 @@ module General = struct return res - and qpredicate_request_aux loc uiinfo (requested : RET.QPredicate.t) = - Pp.(debug 7 (lazy (item __FUNCTION__ (RET.pp (Q requested))))); + and qpredicate_request_aux loc uiinfo (requested : Req.QPredicate.t) = + Pp.(debug 7 (lazy (item __FUNCTION__ (Req.pp (Q requested))))); let@ provable = provable loc in let@ simp_ctxt = simp_ctxt () in let@ global = get_global () in @@ -276,16 +276,16 @@ module General = struct loc (fun re (needed, oarg) -> let continue = (Unchanged, (needed, oarg)) in - assert (RET.steps_constant (fst re)); + assert (Req.steps_constant (fst re)); if IT.is_false needed then continue else ( match re with | Q p', O p'_oarg - when RET.subsumed requested.name p'.name + when Req.subsumed requested.name p'.name && IT.equal step p'.step && BaseTypes.equal (snd requested.q) (snd p'.q) -> - let p' = RET.QPredicate.alpha_rename_ (fst requested.q) p' in + let p' = Req.QPredicate.alpha_rename_ (fst requested.q) p' in let here = Locations.other __FUNCTION__ in let pmatch = (* Work-around for https://github.com/Z3Prover/z3/issues/7352 *) @@ -304,7 +304,7 @@ module General = struct | `False -> (match provable (LC.T pmatch) with | `True -> - Pp.debug 9 (lazy (Pp.item "used resource" (RET.pp (fst re)))); + Pp.debug 9 (lazy (Pp.item "used resource" (Req.pp (fst re)))); let open IT in let needed' = [ needed; not_ (and_ [ iarg_match; p'.permission ] here) here ] @@ -321,7 +321,7 @@ module General = struct let model = Solver.model () in Pp.debug 9 - (lazy (Pp.item "couldn't use q-resource" (RET.pp (fst re)))); + (lazy (Pp.item "couldn't use q-resource" (Req.pp (fst re)))); debug_constraint_failure_diagnostics 9 model @@ -341,7 +341,7 @@ module General = struct let continue = return (needed, oarg) in if (not (IT.is_false needed)) - && RET.subsumed requested.name predicate_name + && Req.subsumed requested.name predicate_name && BaseTypes.equal (snd requested.q) (IT.bt index) then ( let su = IT.make_subst [ (fst requested.q, index) ] in @@ -393,7 +393,7 @@ module General = struct return None - and qpredicate_request loc uiinfo (requested : RET.QPredicate.t) = + and qpredicate_request loc uiinfo (requested : Req.QPredicate.t) = let@ o_oarg = qpredicate_request_aux loc uiinfo requested in let@ oarg_item_bt = WellTyped.oarg_bt_of_pred loc requested.name in match o_oarg with @@ -401,7 +401,7 @@ module General = struct | Some (oarg, rw_time) -> let@ oarg = cases_to_map loc uiinfo (snd requested.q) oarg_item_bt oarg in let r = - RET.QPredicate. + Req.QPredicate. { name = requested.name; pointer = requested.pointer; q = requested.q; @@ -437,19 +437,19 @@ module General = struct loop ftyp [] - and resource_request loc uiinfo (request : RET.t) : (Resources.t * int list) option m = + and resource_request loc uiinfo (request : Req.t) : (Resources.t * int list) option m = match request with | P request -> let@ result = predicate_request loc uiinfo request in return (Option.map - (fun ((p, o), changed_or_deleted) -> ((RET.P p, o), changed_or_deleted)) + (fun ((p, o), changed_or_deleted) -> ((Req.P p, o), changed_or_deleted)) result) | Q request -> let@ result = qpredicate_request loc uiinfo request in return (Option.map - (fun ((q, o), changed_or_deleted) -> ((RET.Q q, o), changed_or_deleted)) + (fun ((q, o), changed_or_deleted) -> ((Req.Q q, o), changed_or_deleted)) result) @@ -520,10 +520,10 @@ module Special = struct let f res found = let found = match res with - | RET.Q _, _ -> found - | RET.P { name = Owned _; pointer; iargs = _ }, _ -> + | Req.Q _, _ -> found + | Req.P { name = Owned _; pointer; iargs = _ }, _ -> alloc_id_matches found pointer - | RET.P { name = PName name; pointer; iargs = _ }, _ -> + | Req.P { name = PName name; pointer; iargs = _ }, _ -> if Sym.equal name Alloc.Predicate.sym then alloc_id_matches found pointer else diff --git a/backend/cn/lib/resourceInference.mli b/backend/cn/lib/resourceInference.mli index 2d6db0116..df4ba53f4 100644 --- a/backend/cn/lib/resourceInference.mli +++ b/backend/cn/lib/resourceInference.mli @@ -28,12 +28,12 @@ module Special : sig val predicate_request : Locations.t -> TypeErrors.situation -> - ResourceTypes.Predicate.t * (Locations.t * string) option -> - ((ResourceTypes.Predicate.t * Resources.oargs) * int list) Typing.m + Request.Predicate.t * (Locations.t * string) option -> + ((Request.Predicate.t * Resources.oargs) * int list) Typing.m val qpredicate_request : Locations.t -> TypeErrors.situation -> - ResourceTypes.QPredicate.t * (Locations.t * string) option -> - ((ResourceTypes.QPredicate.t * Resources.oargs) * int list) Typing.m + Request.QPredicate.t * (Locations.t * string) option -> + ((Request.QPredicate.t * Resources.oargs) * int list) Typing.m end diff --git a/backend/cn/lib/resources.ml b/backend/cn/lib/resources.ml index 2180fd472..4a66cf809 100644 --- a/backend/cn/lib/resources.ml +++ b/backend/cn/lib/resources.ml @@ -1,7 +1,7 @@ module CF = Cerb_frontend module IT = IndexTerms module LC = LogicalConstraints -module RT = ResourceTypes +module RT = Request type oargs = O of IT.t @@ -15,17 +15,15 @@ let request (r, _oargs) = r let oargs_bt (_re, O oargs) = IT.bt oargs -let pp (r, O oargs) = ResourceTypes.pp_aux r (Some oargs) +let pp (r, O oargs) = Request.pp_aux r (Some oargs) let json re : Yojson.Safe.t = `String (Pp.plain (pp re)) let subst substitution ((r, O oargs) : t) = - (ResourceTypes.subst substitution r, O (IT.subst substitution oargs)) + (Request.subst substitution r, O (IT.subst substitution oargs)) -let free_vars (r, O oargs) = - Sym.Set.union (ResourceTypes.free_vars r) (IT.free_vars oargs) - +let free_vars (r, O oargs) = Sym.Set.union (Request.free_vars r) (IT.free_vars oargs) let range_size ct = let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index c3ec31c95..013c17692 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -629,9 +629,9 @@ module LogicalConstraints = struct | _ -> LC.Forall ((q, qbt), body)) end -module ResourceTypes = struct +module Request = struct module Predicate = struct - open ResourceTypes.Predicate + open Request.Predicate let simp simp_ctxt (p : t) = { name = p.name; @@ -641,12 +641,12 @@ module ResourceTypes = struct end module QPredicate = struct - open ResourceTypes.QPredicate + open Request.QPredicate let simp simp_ctxt (qp : t) = let qp = alpha_rename qp in let permission = IndexTerms.simp_flatten simp_ctxt qp.permission in - ResourceTypes.QPredicate. + Request.QPredicate. { name = qp.name; pointer = IndexTerms.simp simp_ctxt qp.pointer; q = qp.q; @@ -657,7 +657,7 @@ module ResourceTypes = struct } end - let simp simp_ctxt : ResourceTypes.t -> ResourceTypes.t = function + let simp simp_ctxt : Request.t -> Request.t = function | P p -> P (Predicate.simp simp_ctxt p) | Q qp -> Q (QPredicate.simp simp_ctxt qp) end diff --git a/backend/cn/lib/testGeneration/genAnalysis.ml b/backend/cn/lib/testGeneration/genAnalysis.ml index 580413645..f3d32b69e 100644 --- a/backend/cn/lib/testGeneration/genAnalysis.ml +++ b/backend/cn/lib/testGeneration/genAnalysis.ml @@ -1,7 +1,7 @@ module CF = Cerb_frontend module BT = BaseTypes module IT = IndexTerms -module RET = ResourceTypes +module Req = Request module LC = LogicalConstraints module RP = ResourcePredicates module LAT = LogicalArgumentTypes @@ -159,8 +159,8 @@ let get_recursive_preds (preds : (Sym.t * RP.definition) list) : Sym.Set.t = |> List.flatten |> List.map snd |> List.map fst - |> List.map RET.get_name - |> List.filter_map (fun (n : RET.name) -> + |> List.map Req.get_name + |> List.filter_map (fun (n : Req.name) -> match n with PName name -> Some name | Owned _ -> None) |> Sym.Set.of_list in diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index 11a6991df..089f2ca2b 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -4,7 +4,7 @@ module AT = ArgumentTypes module LC = LogicalConstraints module LAT = LogicalArgumentTypes module RP = ResourcePredicates -module RET = ResourceTypes +module Req = Request module GBT = GenBaseTypes module GT = GenTerms module GD = GenDefinitions @@ -71,8 +71,8 @@ let compile_vars (generated : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) (lat : I match lat with | Define ((x, it), _info, _) -> (Sym.Set.singleton x, IT.free_vars_bts it) | Resource ((x, ((P { name = Owned _; _ } as ret), bt)), _, _) -> - (Sym.Set.singleton x, Sym.Map.add x bt (RET.free_vars_bts ret)) - | Resource ((x, (ret, _)), _, _) -> (Sym.Set.singleton x, RET.free_vars_bts ret) + (Sym.Set.singleton x, Sym.Map.add x bt (Req.free_vars_bts ret)) + | Resource ((x, (ret, _)), _, _) -> (Sym.Set.singleton x, Req.free_vars_bts ret) | Constraint (lc, _, _) -> (Sym.Set.empty, LC.free_vars_bts lc) | I it -> ( Sym.Set.empty, diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index fa18c23b6..e546d7111 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -8,7 +8,7 @@ module CF = Cerb_frontend module Loc = Locations module RE = Resources module LC = LogicalConstraints -module RET = ResourceTypes +module Req = Request type label_kind = Where.label @@ -89,7 +89,7 @@ let for_situation = function type request_chain_elem = - { resource : RET.t; + { resource : Req.t; loc : Locations.t option; reason : string option } @@ -115,7 +115,7 @@ type message = (* some from Kayvan's compilePredicates module *) | First_iarg_missing | First_iarg_not_pointer of - { pname : ResourceTypes.name; + { pname : Request.name; found_bty : BaseTypes.t } | Missing_member of Id.t @@ -253,7 +253,7 @@ type report = let request_chain_description requests = let pp_req req = - let doc = RET.pp req.resource in + let doc = Req.pp req.resource in let doc = match req.loc with | None -> doc @@ -319,7 +319,7 @@ let pp_message te = let short = !^"Non-pointer first input argument" in let descr = !^"the first input argument of predicate" - ^^^ Pp.squotes (ResourceTypes.pp_name pname) + ^^^ Pp.squotes (Request.pp_name pname) ^^^ !^"must have type" ^^^ Pp.squotes BaseTypes.(pp (Loc ())) ^^^ !^"but was found with type" diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 5a50a0bac..21ca3fbbe 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -1,7 +1,7 @@ open Context module IT = IndexTerms module ITSet = Set.Make (IT) -module RET = ResourceTypes +module Req = Request module RE = Resources open TypeErrors @@ -13,7 +13,7 @@ type s = sym_eqs : IT.t Sym.Map.t; past_models : (Solver.model_with_q * Context.t) list; found_equalities : EqTable.table; - movable_indices : (RET.name * IT.t) list; + movable_indices : (Req.name * IT.t) list; unfold_resources_required : bool; log : Explain.log } @@ -440,7 +440,7 @@ let add_c_internal lc = let add_r_internal ?(derive_constraints = true) loc (r, RE.O oargs) = let@ s = get_typing_context () in let@ simp_ctxt = simp_ctxt () in - let r = Simplify.ResourceTypes.simp simp_ctxt r in + let r = Simplify.Request.simp simp_ctxt r in let oargs = Simplify.IndexTerms.simp simp_ctxt oargs in let pointer_facts = if derive_constraints then @@ -701,7 +701,7 @@ let do_unfold_resources loc = (fun (re, i) (keep, unpack, extract) -> match Pack.unpack loc s.global provable_f2 re with | Some unpackable -> - let pname = RET.get_name (fst re) in + let pname = Req.get_name (fst re) in (keep, (i, pname, unpackable) :: unpack, extract) | None -> let re_reduced, extracted = @@ -725,7 +725,7 @@ let do_unfold_resources loc = let@ _, members = make_return_record loc - ("unpack_" ^ Pp.plain (RET.pp_name pname)) + ("unpack_" ^ Pp.plain (Req.pp_name pname)) (LogicalReturnTypes.binders lrt) in bind_logical_return_internal loc members lrt diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 59ba2d7ca..3d3b5f49b 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -171,10 +171,10 @@ val bind_return : Locations.t -> IndexTerms.t list -> ReturnTypes.t -> IndexTerm val add_movable_index : Locations.t -> (* verbose:bool -> *) - ResourceTypes.name * IndexTerms.t -> + Request.name * IndexTerms.t -> unit m -val get_movable_indices : unit -> (ResourceTypes.name * IndexTerms.t) list m +val get_movable_indices : unit -> (Request.name * IndexTerms.t) list m val record_action : Explain.action * Locations.t -> unit m diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 94feaedd6..d24f5b7f5 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -3,7 +3,7 @@ module LS = LogicalSorts module BT = BaseTypes module TE = TypeErrors module RE = Resources -module RET = ResourceTypes +module Req = Request module LRT = LogicalReturnTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes @@ -981,13 +981,13 @@ let warn_when_not_quantifier_bt ^^^ !^"was provided. This will become an error in the future.") -module WRET = struct +module WReq = struct open IndexTerms let welltyped loc r = - Pp.debug 22 (lazy (Pp.item "WRET: checking" (RET.pp r))); + Pp.debug 22 (lazy (Pp.item "WReq: checking" (Req.pp r))); let@ spec_iargs = - match RET.get_name r with + match Req.get_name r with | Owned (_ct, _init) -> return [] | PName name -> let@ def = Typing.get_resource_predicate_def loc name in @@ -1007,7 +1007,7 @@ module WRET = struct spec_iargs p.iargs in - return (RET.P { name = p.name; pointer; iargs }) + return (Req.P { name = p.name; pointer; iargs }) | Q p -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ pointer = WIT.check loc (BT.Loc ()) p.pointer in @@ -1082,20 +1082,20 @@ module WRET = struct return (permission, iargs)) in return - (RET.Q + (Req.Q { name = p.name; pointer; q = p.q; q_loc = p.q_loc; step; permission; iargs }) end let oarg_bt_of_pred loc = function - | RET.Owned (ct, _init) -> return (Memory.bt_of_sct ct) - | RET.PName pn -> + | Req.Owned (ct, _init) -> return (Memory.bt_of_sct ct) + | Req.PName pn -> let@ def = Typing.get_resource_predicate_def loc pn in return def.oarg_bt let oarg_bt loc = function - | RET.P pred -> oarg_bt_of_pred loc pred.name - | RET.Q pred -> + | Req.P pred -> oarg_bt_of_pred loc pred.name + | Req.Q pred -> let@ item_bt = oarg_bt_of_pred loc pred.name in return (BT.make_map_bt (snd pred.q) item_bt) @@ -1103,7 +1103,7 @@ let oarg_bt loc = function module WRS = struct let welltyped loc (resource, bt) = Pp.(debug 6 (lazy !^__FUNCTION__)); - let@ resource = WRET.welltyped loc resource in + let@ resource = WReq.welltyped loc resource in let@ bt = WBT.is_bt loc bt in let@ oarg_bt = oarg_bt loc resource in let@ () = ensure_base_type loc ~expect:oarg_bt bt in @@ -1825,12 +1825,12 @@ module BaseTyping = struct (CF.Pp_ast.pp_doc_tree (dtree_of_statement stmt)))); match stmt with | Pack_unpack (pack_unpack, pt) -> - let@ p_pt = WRET.welltyped loc (P pt) in - let[@warning "-8"] (RET.P pt) = p_pt in + let@ p_pt = WReq.welltyped loc (P pt) in + let[@warning "-8"] (Req.P pt) = p_pt in return (Pack_unpack (pack_unpack, pt)) | To_from_bytes (to_from, pt) -> - let@ pt = WRET.welltyped loc (P pt) in - let[@warning "-8"] (RET.P pt) = pt in + let@ pt = WReq.welltyped loc (P pt) in + let[@warning "-8"] (Req.P pt) = pt in return (To_from_bytes (to_from, pt)) | Have lc -> let@ lc = WLC.welltyped loc lc in From da498ea85eadc0ecea572dd0dc9554f2f1baa08c Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 17:17:07 +0000 Subject: [PATCH 094/148] Tidy up Resources to Resource --- backend/cn/bin/main.ml | 2 +- backend/cn/lib/check.ml | 8 +-- backend/cn/lib/compile.ml | 3 +- backend/cn/lib/context.ml | 8 +-- backend/cn/lib/explain.ml | 14 ++--- backend/cn/lib/indexTerms.ml | 8 +++ backend/cn/lib/pack.ml | 61 +++++++++++--------- backend/cn/lib/{resources.ml => resource.ml} | 44 +++++--------- backend/cn/lib/resource.mli | 25 ++++++++ backend/cn/lib/resourceInference.ml | 13 ++--- backend/cn/lib/resourceInference.mli | 4 +- backend/cn/lib/typeErrors.ml | 6 +- backend/cn/lib/typing.ml | 15 +++-- backend/cn/lib/typing.mli | 12 ++-- backend/cn/lib/wellTyped.ml | 2 +- 15 files changed, 122 insertions(+), 103 deletions(-) rename backend/cn/lib/{resources.ml => resource.ml} (62%) create mode 100644 backend/cn/lib/resource.mli diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 0f3be56bc..69c293034 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -310,7 +310,7 @@ let verify Check.fail_fast := fail_fast; Diagnostics.diag_string := diag; WellTyped.use_ity := not no_use_ity; - Resources.disable_resource_derived_constraints := disable_resource_derived_constraints; + Resource.disable_resource_derived_constraints := disable_resource_derived_constraints; with_well_formedness_check (* CLI arguments *) ~filename ~macros diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index db11806fd..bc0636c20 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -1161,7 +1161,7 @@ let _check_used_distinct loc used = Generic (Pp.item "undefined behaviour: concurrent update" - (Resources.pp r + (Resource.pp r ^^^ break 1 ^^^ render_upd h ^^^ break 1 @@ -1180,7 +1180,7 @@ let _check_used_distinct loc used = Generic (Pp.item "undefined behaviour: concurrent read & update" - (Resources.pp r + (Resource.pp r ^^^ break 1 ^^^ render_read h ^^^ break 1 @@ -2109,7 +2109,7 @@ let bind_arguments (_loc : Locations.t) (full_args : _ Mu.arguments) = aux_l resources args | Resource ((s, (re, bt)), ((loc, _) as info), args) -> let@ () = add_l s bt (fst info, lazy (Sym.pp s)) in - aux_l (resources @ [ (re, Resources.O (sym_ (s, bt, loc))) ]) args + aux_l (resources @ [ (re, Resource.O (sym_ (s, bt, loc))) ]) args | I i -> return (i, resources) in let rec aux_a = function @@ -2300,7 +2300,7 @@ let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> unit m = let module H = Alloc.History in let H.{ base; size } = H.(split (lookup_ptr ptr here) here) in let addr = addr_ ptr here in - let upper = Resources.upper_bound addr ct here in + let upper = IT.upper_bound addr ct here in let bounds = and_ [ le_ (base, addr) here; diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 19d31cfd0..e0b03b0bf 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -1050,7 +1050,7 @@ module EffectfulTranslation = struct match res with | CN_owned oty -> let@ scty = infer_scty "Owned" oty in - (* we don't take Resources.owned_oargs here because we want to maintain the C-type + (* we don't take Resource.owned_oargs here because we want to maintain the C-type information *) let oargs_ty = Memory.sbt_of_sct scty in return (Req.Owned (scty, Init), oargs_ty) @@ -1336,7 +1336,6 @@ module LocalState = struct end let translate_cn_clause env clause = - let open Resources in let open LocalState in let rec translate_cn_clause_aux env st acc clause = let module LAT = LogicalArgumentTypes in diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index e42c1d5cb..ca836f43d 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -2,7 +2,7 @@ open Pp open List module BT = BaseTypes module LS = LogicalSorts -module RE = Resources +module Res = Resource module LC = LogicalConstraints module Loc = Locations module IntMap = Map.Make (Int) @@ -36,7 +36,7 @@ type resource_history = type t = { computational : (basetype_or_value * l_info) Sym.Map.t; logical : (basetype_or_value * l_info) Sym.Map.t; - resources : (RE.t * int) list * int; + resources : (Res.t * int) list * int; resource_history : resource_history IntMap.t; constraints : LC.Set.t; global : Global.t; @@ -85,7 +85,7 @@ let pp_constraints constraints = let pp (ctxt : t) = item "computational" (pp_variable_bindings ctxt.computational) ^/^ item "logical" (pp_variable_bindings ctxt.logical) - ^/^ item "resources" (Pp.list RE.pp (get_rs ctxt)) + ^/^ item "resources" (Pp.list Res.pp (get_rs ctxt)) ^/^ item "constraints" (pp_constraints ctxt.constraints) @@ -252,7 +252,7 @@ let json (ctxt : t) : Yojson.Safe.t = `Assoc [ ("name", Sym.json sym); ("type", basetype_or_value binding) ]) (Sym.Map.bindings ctxt.logical) in - let resources = List.map RE.json (get_rs ctxt) in + let resources = List.map Res.json (get_rs ctxt) in let constraints = List.map LC.json (LC.Set.elements ctxt.constraints) in let json_record = `Assoc diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index 2e41df207..5049c2055 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -1,7 +1,7 @@ open Report module IT = IndexTerms module BT = BaseTypes -module RE = Resources +module Res = Resource module REP = ResourcePredicates module Req = Request module LC = LogicalConstraints @@ -16,7 +16,6 @@ open Request open IndexTerms open Pp open C -open Resources (* perhaps somehow unify with above *) type action = @@ -298,8 +297,7 @@ let state ctxt log model_with_q extras = let same_res, diff_res = match extras.request with | None -> ([], get_rs ctxt) - | Some req -> - List.partition (fun r -> Req.same_name req (RE.request r)) (get_rs ctxt) + | Some req -> List.partition (fun (r, _) -> Req.same_name req r) (get_rs ctxt) in let interesting_diff_res, uninteresting_diff_res = List.partition @@ -311,9 +309,9 @@ let state ctxt log model_with_q extras = in let with_suff mb x = match mb with None -> x | Some d -> d ^^^ x in let pp_res mb_suff (rt, args) = - { original = with_suff mb_suff (RE.pp (rt, args)); + { original = with_suff mb_suff (Res.pp (rt, args)); simplified = - [ with_suff mb_suff (RE.pp (Interval.Solver.simp_rt evaluate rt, args)) ] + [ with_suff mb_suff (Res.pp (Interval.Solver.simp_rt evaluate rt, args)) ] } in let interesting = @@ -340,8 +338,8 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra (* } *) (* in *) (* let res_entry req_cmp same res = { *) - (* res = RE.pp res; *) - (* res_span = Spans.pp_model_spans model ctxt.global req_cmp (RE.request res) *) + (* res = Res.pp res; *) + (* res_span = Spans.pp_model_spans model ctxt.global req_cmp (Res.request res) *) (* ^^ (if same then !^" - same-type" else !^"") *) (* } *) (* in *) diff --git a/backend/cn/lib/indexTerms.ml b/backend/cn/lib/indexTerms.ml index 97891cc62..72373c926 100644 --- a/backend/cn/lib/indexTerms.ml +++ b/backend/cn/lib/indexTerms.ml @@ -729,6 +729,14 @@ let addr_ it loc = cast_ Memory.uintptr_bt it loc +let upper_bound addr ct loc = + let range_size ct = + let size = Memory.size_of_ctype ct in + num_lit_ (Z.of_int size) Memory.uintptr_bt loc + in + add_ (addr, range_size ct) loc + + (* for integer-mode: cast_ Integer it *) let allocId_ it loc = cast_ Alloc_id it loc diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index 3b47992b9..624e51252 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -1,6 +1,5 @@ -open IndexTerms open Request -open Resources +open Resource open ResourcePredicates open Memory module IT = IndexTerms @@ -12,26 +11,29 @@ let resource_empty provable resource = let loc = Cerb_location.other __FUNCTION__ in let constr = match resource with - | P _, _ -> LC.t_ (bool_ false loc) - | Q p, _ -> LC.forall_ p.q (not_ p.permission loc) + | P _, _ -> LC.t_ (IT.bool_ false loc) + | Q p, _ -> LC.forall_ p.q (IT.not_ p.permission loc) in match provable constr with | `True -> `Empty | `False -> `NonEmpty (constr, Solver.model ()) -let unfolded_array loc init (ict, olength) pointer = +let unfolded_array loc' init (ict, olength) pointer = let length = Option.get olength in - let q_s, q = IT.fresh_named Memory.uintptr_bt "i" loc in + let q_s, q = IT.fresh_named Memory.uintptr_bt "i" loc' in Q { name = Owned (ict, init); pointer; q = (q_s, Memory.uintptr_bt); - q_loc = loc; - step = uintptr_int_ (Memory.size_of_ctype ict) loc; + q_loc = loc'; + step = IT.uintptr_int_ (Memory.size_of_ctype ict) loc'; iargs = []; permission = - and_ [ (uintptr_int_ 0 loc %<= q) loc; (q %< uintptr_int_ length loc) loc ] loc + IT.( + and_ + [ (uintptr_int_ 0 loc' %<= q) loc'; (q %< uintptr_int_ length loc') loc' ] + loc') } @@ -55,7 +57,7 @@ let packing_ft loc global provable ret = let request = P { name = Owned (mct, init); - pointer = memberShift_ (ret.pointer, tag, member) loc; + pointer = IT.memberShift_ (ret.pointer, tag, member) loc; iargs = [] } in @@ -69,7 +71,8 @@ let packing_ft loc global provable ret = let request = P { name = Owned (padding_ct, Uninit); - pointer = pointer_offset_ (ret.pointer, uintptr_int_ offset loc) loc; + pointer = + IT.pointer_offset_ (ret.pointer, IT.uintptr_int_ offset loc) loc; iargs = [] } in @@ -81,7 +84,7 @@ let packing_ft loc global provable ret = layout (LRT.I, []) in - let at = LAT.of_lrt lrt (LAT.I (struct_ (tag, value) loc)) in + let at = LAT.of_lrt lrt (LAT.I (IT.struct_ (tag, value) loc)) in Some at | PName pn -> let def = Sym.Map.find pn global.resource_predicates in @@ -106,10 +109,10 @@ let unpack_owned loc global (ct, init) pointer (O o) = let mresource = ( P { name = Owned (mct, init); - pointer = memberShift_ (pointer, tag, member) loc; + pointer = IT.memberShift_ (pointer, tag, member) loc; iargs = [] }, - O (member_ ~member_bt:(Memory.bt_of_sct mct) (o, member) loc) ) + O (IT.member_ ~member_bt:(Memory.bt_of_sct mct) (o, member) loc) ) in mresource :: res | None -> @@ -117,10 +120,10 @@ let unpack_owned loc global (ct, init) pointer (O o) = let mresource = ( P { name = Owned (padding_ct, Uninit); - pointer = pointer_offset_ (pointer, uintptr_int_ offset loc) loc; + pointer = IT.pointer_offset_ (pointer, IT.uintptr_int_ offset loc) loc; iargs = [] }, - O (default_ (Memory.bt_of_sct padding_ct) loc) ) + O (IT.default_ (Memory.bt_of_sct padding_ct) loc) ) in mresource :: res) layout @@ -156,28 +159,30 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O let index_permission = IT.subst su ret.permission in (match prove_or_model (LC.t_ index_permission) with | `True -> - let loc = Cerb_location.other __FUNCTION__ in + let loc' = Cerb_location.other __FUNCTION__ in let at_index = ( P { name = ret.name; pointer = - pointer_offset_ - ( ret.pointer, - mul_ - ( cast_ Memory.uintptr_bt ret.step loc, - cast_ Memory.uintptr_bt index loc ) - loc ) - loc; + IT.( + pointer_offset_ + ( ret.pointer, + mul_ + ( cast_ Memory.uintptr_bt ret.step loc', + cast_ Memory.uintptr_bt index loc' ) + loc' ) + loc'); iargs = List.map (IT.subst su) ret.iargs }, - O (map_get_ o index loc) ) + O (IT.map_get_ o index loc') ) in let ret_reduced = { ret with permission = - and_ - [ ret.permission; ne__ (sym_ (fst ret.q, snd ret.q, loc)) index loc ] - loc + IT.( + and_ + [ ret.permission; ne__ (sym_ (fst ret.q, snd ret.q, loc')) index loc' ] + loc') } in (* tmsg "successfully extracted" (lazy (IT.pp index)); *) diff --git a/backend/cn/lib/resources.ml b/backend/cn/lib/resource.ml similarity index 62% rename from backend/cn/lib/resources.ml rename to backend/cn/lib/resource.ml index 4a66cf809..0d6e0d436 100644 --- a/backend/cn/lib/resources.ml +++ b/backend/cn/lib/resource.ml @@ -1,45 +1,33 @@ -module CF = Cerb_frontend module IT = IndexTerms -module LC = LogicalConstraints -module RT = Request +module Req = Request -type oargs = O of IT.t +type output = O of IT.t [@@ocaml.unboxed] -let pp_oargs (O t) = IT.pp t +let pp_output (O t) = IT.pp t -type resource = RT.t * oargs +type predicate = Req.Predicate.t * output -type t = resource +type qpredicate = Req.QPredicate.t * output -let request (r, _oargs) = r +type t = Req.t * output -let oargs_bt (_re, O oargs) = IT.bt oargs - -let pp (r, O oargs) = Request.pp_aux r (Some oargs) +let pp (r, O output) = Req.pp_aux r (Some output) let json re : Yojson.Safe.t = `String (Pp.plain (pp re)) let subst substitution ((r, O oargs) : t) = - (Request.subst substitution r, O (IT.subst substitution oargs)) - - -let free_vars (r, O oargs) = Sym.Set.union (Request.free_vars r) (IT.free_vars oargs) - -let range_size ct = - let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in - let size = Memory.size_of_ctype ct in - IT.num_lit_ (Z.of_int size) Memory.uintptr_bt here + (Req.subst substitution r, O (IT.subst substitution oargs)) -let upper_bound addr ct loc = IT.add_ (addr, range_size ct) loc +let free_vars (r, O oargs) = Sym.Set.union (Req.free_vars r) (IT.free_vars oargs) (* assumption: the resource is owned *) -let derived_lc1 ((resource : RT.t), O oarg) = +let derived_lc1 ((resource : Req.t), O output) = let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in match resource with | P { name = Owned (ct, _); pointer; iargs = _ } -> let addr = IT.addr_ pointer here in - let upper = upper_bound addr ct here in + let upper = IT.upper_bound addr ct here in let alloc_bounds = if !IT.use_vip then let module H = Alloc.History in @@ -50,26 +38,26 @@ let derived_lc1 ((resource : RT.t), O oarg) = in [ IT.hasAllocId_ pointer here; IT.(le_ (addr, upper) here) ] @ alloc_bounds | P { name; pointer; iargs = [] } - when !IT.use_vip && RT.(equal_name name Predicate.alloc) -> + when !IT.use_vip && Req.(equal_name name Predicate.alloc) -> let module H = Alloc.History in let lookup = H.lookup_ptr pointer here in let H.{ base; size } = H.split lookup here in - [ IT.(eq_ (lookup, oarg) here); IT.(le_ (base, add_ (base, size) here) here) ] + [ IT.(eq_ (lookup, output) here); IT.(le_ (base, add_ (base, size) here) here) ] | Q { name = Owned _; pointer; _ } -> [ IT.hasAllocId_ pointer here ] | P { name = PName _; pointer = _; iargs = _ } | Q { name = PName _; _ } -> [] (* assumption: both resources are owned at the same *) (* todo, depending on how much we need *) -let derived_lc2 ((resource : RT.t), _) ((resource' : RT.t), _) = +let derived_lc2 ((resource : Req.t), _) ((resource' : Req.t), _) = match (resource, resource') with | ( P { name = Owned (ct1, _); pointer = p1; iargs = _ }, P { name = Owned (ct2, _); pointer = p2; iargs = _ } ) -> let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in let addr1 = IT.addr_ p1 here in let addr2 = IT.addr_ p2 here in - let up1 = upper_bound addr1 ct1 here in - let up2 = upper_bound addr2 ct2 here in + let up1 = IT.upper_bound addr1 ct1 here in + let up2 = IT.upper_bound addr2 ct2 here in [ IT.(or2_ (le_ (up2, addr1) here, le_ (up1, addr2) here) here) ] | _ -> [] diff --git a/backend/cn/lib/resource.mli b/backend/cn/lib/resource.mli new file mode 100644 index 000000000..8ffceae49 --- /dev/null +++ b/backend/cn/lib/resource.mli @@ -0,0 +1,25 @@ +type output = O of IndexTerms.t [@@unboxed] + +val pp_output : output -> Pp.document + +type predicate = Request.Predicate.t * output + +type qpredicate = Request.QPredicate.t * output + +type t = Request.t * output + +val pp : Request.t * output -> Pp.document + +val json : Request.t * output -> Yojson.Safe.t + +val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t + +val free_vars : t -> Sym.Set.t + +val derived_lc1 : t -> IndexTerms.t list + +val derived_lc2 : t -> t -> IndexTerms.t list + +val disable_resource_derived_constraints : bool ref + +val pointer_facts : new_resource:t -> old_resources:t list -> IndexTerms.t list diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 21faf27d5..1238ebccf 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -1,9 +1,6 @@ module IT = IndexTerms module LC = LogicalConstraints module Req = Request - -type oargs = Resources.oargs = O of IT.t - open Typing let debug_constraint_failure_diagnostics @@ -127,7 +124,7 @@ module General = struct { requests = request_chain; situation; model; ctxt } in { loc; msg }) - | Some ((re, O oargs), changed_or_deleted') -> + | Some ((re, Resource.O oargs), changed_or_deleted') -> assert (Request.equal re resource); let oargs = Simplify.IndexTerms.simp simp_ctxt oargs in let changed_or_deleted = changed_or_deleted @ changed_or_deleted' in @@ -161,7 +158,7 @@ module General = struct (* TODO: check that oargs are in the same order? *) let rec predicate_request loc (uiinfo : uiinfo) (requested : Req.Predicate.t) - : ((Req.Predicate.t * Resources.oargs) * int list) option m + : (Resource.predicate * int list) option m = Pp.(debug 7 (lazy (item __FUNCTION__ (Req.pp (P requested))))); let start_timing = Pp.time_log_start __FUNCTION__ "" in @@ -241,7 +238,7 @@ module General = struct let@ o, changed_or_deleted = ftyp_args_request_for_pack loc uiinfo packing_ft in - return (Some ((requested, O o), changed_or_deleted)) + return (Some ((requested, Resource.O o), changed_or_deleted)) | None -> let req_pp = lazy (Req.pp (P requested)) in Pp.debug 9 (Lazy.map (Pp.item "no pack rule for resource, failing") req_pp); @@ -411,7 +408,7 @@ module General = struct iargs = requested.iargs } in - return (Some ((r, O oarg), rw_time)) + return (Some ((r, Resource.O oarg), rw_time)) and ftyp_args_request_for_pack loc uiinfo ftyp = @@ -437,7 +434,7 @@ module General = struct loop ftyp [] - and resource_request loc uiinfo (request : Req.t) : (Resources.t * int list) option m = + and resource_request loc uiinfo (request : Req.t) : (Resource.t * int list) option m = match request with | P request -> let@ result = predicate_request loc uiinfo request in diff --git a/backend/cn/lib/resourceInference.mli b/backend/cn/lib/resourceInference.mli index df4ba53f4..8b5ac6886 100644 --- a/backend/cn/lib/resourceInference.mli +++ b/backend/cn/lib/resourceInference.mli @@ -29,11 +29,11 @@ module Special : sig : Locations.t -> TypeErrors.situation -> Request.Predicate.t * (Locations.t * string) option -> - ((Request.Predicate.t * Resources.oargs) * int list) Typing.m + (Resource.predicate * int list) Typing.m val qpredicate_request : Locations.t -> TypeErrors.situation -> Request.QPredicate.t * (Locations.t * string) option -> - ((Request.QPredicate.t * Resources.oargs) * int list) Typing.m + (Resource.qpredicate * int list) Typing.m end diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index e546d7111..989c8c2d5 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -6,7 +6,7 @@ module IT = IndexTerms module LS = LogicalSorts module CF = Cerb_frontend module Loc = Locations -module RE = Resources +module Res = Resource module LC = LogicalConstraints module Req = Request @@ -132,7 +132,7 @@ type message = model : Solver.model_with_q } | Unused_resource of - { resource : RE.t; + { resource : Res.t; ctxt : Context.t * log; model : Solver.model_with_q } @@ -351,7 +351,7 @@ let pp_message te = let state = trace ctxt model Explain.{ no_ex with request = orequest } in { short; descr; state = Some state } | Unused_resource { resource; ctxt; model } -> - let resource = RE.pp resource in + let resource = Res.pp resource in let short = !^"Left-over unused resource" ^^^ squotes resource in let state = trace ctxt model Explain.no_ex in { short; descr = None; state = Some state } diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 21ca3fbbe..232077ce5 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -2,7 +2,7 @@ open Context module IT = IndexTerms module ITSet = Set.Make (IT) module Req = Request -module RE = Resources +module Res = Resource open TypeErrors type solver = Solver.solver @@ -437,16 +437,14 @@ let add_c_internal lc = return () -let add_r_internal ?(derive_constraints = true) loc (r, RE.O oargs) = +let add_r_internal ?(derive_constraints = true) loc (r, Res.O oargs) = let@ s = get_typing_context () in let@ simp_ctxt = simp_ctxt () in let r = Simplify.Request.simp simp_ctxt r in let oargs = Simplify.IndexTerms.simp simp_ctxt oargs in let pointer_facts = if derive_constraints then - Resources.pointer_facts - ~new_resource:(r, RE.O oargs) - ~old_resources:(Context.get_rs s) + Res.pointer_facts ~new_resource:(r, Res.O oargs) ~old_resources:(Context.get_rs s) else [] in @@ -604,7 +602,7 @@ let bind_logical_return_internal loc = aux members (LogicalReturnTypes.subst (IT.make_subst [ (s, member) ]) lrt) | member :: members, Resource ((s, (re, bt)), _, lrt) -> let@ () = ensure_base_type loc ~expect:bt (IT.bt member) in - let@ () = add_r_internal loc (re, RE.O member) in + let@ () = add_r_internal loc (re, Res.O member) in aux members (LogicalReturnTypes.subst (IT.make_subst [ (s, member) ]) lrt) | members, Constraint (lc, _, lrt) -> let@ () = add_c_internal lc in @@ -640,9 +638,10 @@ let bind_return loc members (rt : ReturnTypes.t) = type changed = | Deleted | Unchanged - | Changed of RE.t + | Changed of Res.t -let map_and_fold_resources_internal loc (f : RE.t -> 'acc -> changed * 'acc) (acc : 'acc) = +let map_and_fold_resources_internal loc (f : Res.t -> 'acc -> changed * 'acc) (acc : 'acc) + = let@ s = get_typing_context () in let@ provable_f = provable_internal loc in let resources, orig_ix = s.resources in diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 3d3b5f49b..77240c1d4 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -38,9 +38,9 @@ val get_cs : unit -> Context.LC.Set.t m val simp_ctxt : unit -> Simplify.simp_ctxt m -val all_resources : Locations.t -> Resources.t list m +val all_resources : Locations.t -> Resource.t list m -val all_resources_tagged : Locations.t -> ((Resources.t * int) list * int) m +val all_resources_tagged : Locations.t -> ((Resource.t * int) list * int) m val provable : Locations.t -> (LogicalConstraints.t -> [> `True | `False ]) m @@ -78,9 +78,9 @@ val add_c : Locations.t -> LogicalConstraints.t -> unit m val add_cs : Locations.t -> LogicalConstraints.t list -> unit m -val add_r : Locations.t -> Resources.t -> unit m +val add_r : Locations.t -> Resource.t -> unit m -val add_rs : Locations.t -> Resources.t list -> unit m +val add_rs : Locations.t -> Resource.t list -> unit m val set_datatype_order : Sym.t list list option -> unit m @@ -91,11 +91,11 @@ val res_history : Locations.t -> int -> Context.resource_history m type changed = | Deleted | Unchanged - | Changed of Resources.t + | Changed of Resource.t val map_and_fold_resources : Locations.t -> - (Resources.t -> 'acc -> changed * 'acc) -> + (Resource.t -> 'acc -> changed * 'acc) -> 'acc -> ('acc * int list) m diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index d24f5b7f5..1de5f28a1 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -2,7 +2,7 @@ module CF = Cerb_frontend module LS = LogicalSorts module BT = BaseTypes module TE = TypeErrors -module RE = Resources +module Res = Resource module Req = Request module LRT = LogicalReturnTypes module AT = ArgumentTypes From 67cc5fbb9d12a201eb158d6f4b666c054f85dbf9 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 17:32:11 +0000 Subject: [PATCH 095/148] Remove unused LogicalSorts module --- backend/cn/lib/argumentTypes.ml | 1 - backend/cn/lib/check.ml | 2 +- backend/cn/lib/context.ml | 1 - backend/cn/lib/explain.ml | 1 - backend/cn/lib/lemmata.ml | 1 - backend/cn/lib/logicalArgumentTypes.ml | 1 - backend/cn/lib/logicalFunctions.ml | 7 +++---- backend/cn/lib/logicalSorts.ml | 11 ----------- backend/cn/lib/resourcePredicates.ml | 8 +++----- backend/cn/lib/solver.ml | 2 +- backend/cn/lib/solver.mli | 9 ++++----- backend/cn/lib/typeErrors.ml | 1 - backend/cn/lib/typing.ml | 8 ++------ backend/cn/lib/typing.mli | 4 +--- backend/cn/lib/wellTyped.ml | 27 +++++++++++--------------- 15 files changed, 26 insertions(+), 58 deletions(-) delete mode 100644 backend/cn/lib/logicalSorts.ml diff --git a/backend/cn/lib/argumentTypes.ml b/backend/cn/lib/argumentTypes.ml index 842324d22..575bcbb61 100644 --- a/backend/cn/lib/argumentTypes.ml +++ b/backend/cn/lib/argumentTypes.ml @@ -1,7 +1,6 @@ open Locations module BT = BaseTypes module IT = IndexTerms -module LS = LogicalSorts module Req = Request module LC = LogicalConstraints module LAT = LogicalArgumentTypes diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index bc0636c20..d3b100e9d 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -1063,7 +1063,7 @@ end = struct check_pexpr pe k - let check_arg_it (loc, it_arg) ~(expect : LogicalSorts.t) k = + let check_arg_it (loc, it_arg) ~(expect : BT.t) k = let@ it_arg = WellTyped.WIT.check loc expect it_arg in k it_arg diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index ca836f43d..50c118a43 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -1,7 +1,6 @@ open Pp open List module BT = BaseTypes -module LS = LogicalSorts module Res = Resource module LC = LogicalConstraints module Loc = Locations diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index 5049c2055..5ba4c9d76 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -7,7 +7,6 @@ module Req = Request module LC = LogicalConstraints module LF = LogicalFunctions module LAT = LogicalArgumentTypes -module LS = LogicalSorts module StringMap = Map.Make (String) module C = Context module Loc = Locations diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index 57a68d036..baac426cb 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -1,6 +1,5 @@ module IT = IndexTerms module BT = BaseTypes -module LS = LogicalSorts module LRT = LogicalReturnTypes module RT = ReturnTypes module AT = ArgumentTypes diff --git a/backend/cn/lib/logicalArgumentTypes.ml b/backend/cn/lib/logicalArgumentTypes.ml index 44acad2b1..1abcdf76c 100644 --- a/backend/cn/lib/logicalArgumentTypes.ml +++ b/backend/cn/lib/logicalArgumentTypes.ml @@ -1,7 +1,6 @@ open Locations module BT = BaseTypes module IT = IndexTerms -module LS = LogicalSorts module Req = Request module LC = LogicalConstraints diff --git a/backend/cn/lib/logicalFunctions.ml b/backend/cn/lib/logicalFunctions.ml index ce878d03f..a5d391047 100644 --- a/backend/cn/lib/logicalFunctions.ml +++ b/backend/cn/lib/logicalFunctions.ml @@ -1,6 +1,5 @@ module Loc = Locations module IT = IndexTerms -module BT = BaseTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes open IndexTerms @@ -18,10 +17,10 @@ let subst_def_or_uninterp subst = function type definition = { loc : Locations.t; - args : (Sym.t * LogicalSorts.t) list; + args : (Sym.t * BaseTypes.t) list; (* If the predicate is supposed to get used in a quantified form, one of the arguments has to be the index/quantified variable. For now at least. *) - return_bt : BT.t; + return_bt : BaseTypes.t; emit_coq : bool; definition : def_or_uninterp } @@ -37,7 +36,7 @@ let given_to_solver def = let pp_args xs = Pp.flow_map (Pp.break 1) - (fun (sym, typ) -> Pp.parens (Pp.typ (Sym.pp sym) (BT.pp typ))) + (fun (sym, typ) -> Pp.parens (Pp.typ (Sym.pp sym) (BaseTypes.pp typ))) xs diff --git a/backend/cn/lib/logicalSorts.ml b/backend/cn/lib/logicalSorts.ml deleted file mode 100644 index 854fe4681..000000000 --- a/backend/cn/lib/logicalSorts.ml +++ /dev/null @@ -1,11 +0,0 @@ -module Loc = Locations - -type t = BaseTypes.t - -type sort = t - -let pp bt = BaseTypes.pp bt - -let json bt : Yojson.Safe.t = BaseTypes.json bt - -let equal t1 t2 = BaseTypes.equal t1 t2 diff --git a/backend/cn/lib/resourcePredicates.ml b/backend/cn/lib/resourcePredicates.ml index a8fade39f..558ad0adf 100644 --- a/backend/cn/lib/resourcePredicates.ml +++ b/backend/cn/lib/resourcePredicates.ml @@ -1,6 +1,4 @@ -module BT = BaseTypes module IT = IndexTerms -module LS = LogicalSorts module LRT = LogicalReturnTypes module LC = LogicalConstraints module AT = ArgumentTypes @@ -39,8 +37,8 @@ let clause_lrt (pred_oarg : IT.t) clause_packing_ft = type definition = { loc : Loc.t; pointer : Sym.t; - iargs : (Sym.t * LS.t) list; - oarg_bt : LS.t; + iargs : (Sym.t * BaseTypes.t) list; + oarg_bt : BaseTypes.t; clauses : clause list option } @@ -56,7 +54,7 @@ let alloc = let pp_definition def = item "pointer" (Sym.pp def.pointer) ^/^ item "iargs" (Pp.list (fun (s, _) -> Sym.pp s) def.iargs) - ^/^ item "oarg_bt" (BT.pp def.oarg_bt) + ^/^ item "oarg_bt" (BaseTypes.pp def.oarg_bt) ^/^ item "clauses" (match def.clauses with diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 1b889895a..49f2b8362 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -1299,7 +1299,7 @@ type model = int type model_fn = IT.t -> IT.t option -type model_with_q = model * (Sym.t * LogicalSorts.t) list +type model_with_q = model * (Sym.t * BaseTypes.t) list type model_table = (model, model_fn) Hashtbl.t diff --git a/backend/cn/lib/solver.mli b/backend/cn/lib/solver.mli index d63d4ffff..3c11f070e 100644 --- a/backend/cn/lib/solver.mli +++ b/backend/cn/lib/solver.mli @@ -3,14 +3,13 @@ type solver type model -(* (TODO: BCP: The "with quantifiers" part will be the instantiations that the solver - found -- is that right?) *) -type model_with_q = model * (Sym.t * LogicalSorts.t) list +(** Model with quantifier instantiations *) +type model_with_q = model * (Sym.t * BaseTypes.t) list val empty_model : model -(* Global flags to pass to the solver (TODO: BCP: Could use a bit more documentation, - maybe) *) +(** Global flags to pass to the solver. Useful for reproducing bugs which only + appear with specific counter-examples. *) val random_seed : int ref module Logger : sig diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index 989c8c2d5..ffaf02ef1 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -3,7 +3,6 @@ open Pp open Locations module BT = BaseTypes module IT = IndexTerms -module LS = LogicalSorts module CF = Cerb_frontend module Loc = Locations module Res = Resource diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 232077ce5..793e653fb 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -566,17 +566,13 @@ let model_with_internal loc prop = (* functions for binding return types and associated auxiliary functions *) -let ensure_logical_sort (loc : Loc.t) ~(expect : LS.t) (has : LS.t) : unit m = - if LS.equal has expect then +let ensure_base_type (loc : Loc.t) ~(expect : BT.t) (has : BT.t) : unit m = + if BT.equal has expect then return () else fail (fun _ -> { loc; msg = Mismatch { has = BT.pp has; expect = BT.pp expect } }) -let ensure_base_type (loc : Loc.t) ~(expect : BT.t) (has : BT.t) : unit m = - ensure_logical_sort loc ~expect has - - let make_return_record loc (record_name : string) record_members = let record_s = Sym.fresh_make_uniq record_name in (* let record_s = Sym.fresh_make_uniq (TypeErrors.call_prefix call_situation) in *) diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 77240c1d4..1171dc4c8 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -150,9 +150,7 @@ val test_value_eqs val embed_resultat : 'a Resultat.t -> 'a m -val ensure_logical_sort : Locations.t -> expect:LogicalSorts.t -> LogicalSorts.t -> unit m - -val ensure_base_type : Locations.t -> expect:LogicalSorts.t -> LogicalSorts.t -> unit m +val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit m val make_return_record : Locations.t -> diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 1de5f28a1..bcf16fdea 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -1,5 +1,4 @@ module CF = Cerb_frontend -module LS = LogicalSorts module BT = BaseTypes module TE = TypeErrors module Res = Resource @@ -207,10 +206,6 @@ module WBT = struct { loc; msg = Generic (Pp.item "no standard encoding type for constant" (Pp.z z)) }) end -module WLS = struct - let is_ls = WBT.is_bt -end - module WCT = struct open Sctypes @@ -948,13 +943,13 @@ module WIT = struct and check expect_loc expect_ls it = - let@ ls = WLS.is_ls expect_loc expect_ls in + let@ ls = WBT.is_bt expect_loc expect_ls in let@ it = infer it in let@ loc = get_location_for_type it in - if LS.equal ls (IT.bt it) then + if BT.equal ls (IT.bt it) then return it else ( - let expected = Pp.plain @@ LS.pp ls in + let expected = Pp.plain @@ BT.pp ls in let reason = Either.Left expect_loc in fail (illtyped_index_term loc it (IT.bt it) ~expected ~reason)) end @@ -2263,10 +2258,10 @@ module WRPD = struct (let@ () = add_l pointer BT.(Loc ()) (loc, lazy (Pp.string "ptr-var")) in let@ iargs = ListM.mapM - (fun (s, ls) -> - let@ ls = WLS.is_ls loc ls in - let@ () = add_l s ls (loc, lazy (Pp.string "input-var")) in - return (s, ls)) + (fun (s, bt) -> + let@ bt = WBT.is_bt loc bt in + let@ () = add_l s bt (loc, lazy (Pp.string "input-var")) in + return (s, bt)) iargs in let@ oarg_bt = WBT.is_bt loc oarg_bt in @@ -2312,10 +2307,10 @@ module WLFD = struct pure (let@ args = ListM.mapM - (fun (s, ls) -> - let@ ls = WLS.is_ls loc ls in - let@ () = add_l s ls (loc, lazy (Pp.string "arg-var")) in - return (s, ls)) + (fun (s, bt) -> + let@ bt = WBT.is_bt loc bt in + let@ () = add_l s bt (loc, lazy (Pp.string "arg-var")) in + return (s, bt)) args in let@ return_bt = WBT.is_bt loc return_bt in From 2d4d9a4a3501a8de1b3d1152cbff3e4a4f18875b Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 17:35:20 +0000 Subject: [PATCH 096/148] Remove LogicalConstraints.t_ function --- backend/cn/lib/compile.ml | 2 +- backend/cn/lib/core_to_mucore.ml | 6 +++--- backend/cn/lib/logicalConstraints.ml | 2 -- backend/cn/lib/pack.ml | 4 ++-- backend/cn/lib/resourceInference.ml | 2 +- backend/cn/lib/resourcePredicates.ml | 12 +++++------- backend/cn/lib/typing.ml | 8 ++++---- backend/cn/lib/wellTyped.ml | 18 +++++++++--------- 8 files changed, 25 insertions(+), 29 deletions(-) diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index e0b03b0bf..5913af58c 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -1485,7 +1485,7 @@ let make_rt loc (env : env) st (s, ct) (accesses, ensures) = in (* let info = (loc, Some "return value good") in *) (* let here = Locations.other __FUNCTION__ in *) - (* let lrt = LRT.mConstraint (LC.t_ (IT.good_ (ct, IT.sym_ (s, bt, here)) here), info) + (* let lrt = LRT.mConstraint (LC.T (IT.good_ (ct, IT.sym_ (s, bt, here)) here), info) lrt in *) return (RT.mComputational ((s, bt), (loc, None)) lrt) diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 3d8bb6977..b82179a2b 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -944,7 +944,7 @@ let make_label_args f_i loc env st args (accesses, inv) = (* let good_pointer_lc = *) (* let info = (loc, Some (Sym.pp_string s ^ " good")) in *) (* let here = Locations.other __FUNCTION__ in *) - (* (LC.t_ (IT.good_ (Pointer sct, IT.sym_ (s, BT.Loc, here)) here), info) *) + (* (LC.T (IT.good_ (Pointer sct, IT.sym_ (s, BT.Loc, here)) here), info) *) (* in *) let@ oa_name, ((pt_ret, oa_bt), lcs), value = C.ownership (loc, (s, ct)) env in let env = C.add_logical oa_name oa_bt env in @@ -981,7 +981,7 @@ let make_function_args f_i loc env args (accesses, requires) = (* let good_lc = *) (* let info = (loc, Some (Sym.pp_string pure_arg ^ " good")) in *) (* let here = Locations.other __FUNCTION__ in *) - (* (LC.t_ (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) + (* (LC.T (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) (* in *) let@ at = aux (arg_states @ [ (mut_arg, arg_state) ]) (* good_lc :: *) good_lcs env st rest @@ -1020,7 +1020,7 @@ let make_fun_with_spec_args f_i loc env args requires = (* let good_lc = *) (* let info = (loc, Some (Sym.pp_string pure_arg ^ " good")) in *) (* let here = Locations.other __FUNCTION__ in *) - (* (LC.t_ (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) + (* (LC.T (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) (* in *) let@ at = aux (* good_lc :: *) good_lcs env st rest in return (Mu.mComputational ((pure_arg, bt), (loc, None)) at) diff --git a/backend/cn/lib/logicalConstraints.ml b/backend/cn/lib/logicalConstraints.ml index c240db8f1..c1444353b 100644 --- a/backend/cn/lib/logicalConstraints.ml +++ b/backend/cn/lib/logicalConstraints.ml @@ -61,8 +61,6 @@ let alpha_equivalent lc lc' = | _ -> false -let t_ it = T it - let forall_ (s, bt) it = Forall ((s, bt), it) let is_sym_lhs_equality = function diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index 624e51252..cb5eff088 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -11,7 +11,7 @@ let resource_empty provable resource = let loc = Cerb_location.other __FUNCTION__ in let constr = match resource with - | P _, _ -> LC.t_ (IT.bool_ false loc) + | P _, _ -> LC.T (IT.bool_ false loc) | Q p, _ -> LC.forall_ p.q (IT.not_ p.permission loc) in match provable constr with @@ -157,7 +157,7 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O -> let su = IT.make_subst [ (fst ret.q, index) ] in let index_permission = IT.subst su ret.permission in - (match prove_or_model (LC.t_ index_permission) with + (match prove_or_model (LC.T index_permission) with | `True -> let loc' = Cerb_location.other __FUNCTION__ in let at_index = diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 1238ebccf..43acf24c2 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -343,7 +343,7 @@ module General = struct then ( let su = IT.make_subst [ (fst requested.q, index) ] in let needed_at_index = IT.subst su needed in - match provable (LC.t_ needed_at_index) with + match provable (LC.T needed_at_index) with | `False -> continue | `True -> let@ o_re_index = diff --git a/backend/cn/lib/resourcePredicates.ml b/backend/cn/lib/resourcePredicates.ml index 558ad0adf..ec970e646 100644 --- a/backend/cn/lib/resourcePredicates.ml +++ b/backend/cn/lib/resourcePredicates.ml @@ -5,7 +5,6 @@ module AT = ArgumentTypes module LAT = LogicalArgumentTypes module StringMap = Map.Make (String) module Loc = Locations -open Pp type clause = { loc : Loc.t; @@ -14,6 +13,7 @@ type clause = } let pp_clause { loc = _; guard; packing_ft } = + let open Pp in item "condition" (IT.pp guard) ^^ comma ^^^ item "return type" (LAT.pp IT.pp packing_ft) @@ -28,7 +28,7 @@ let clause_lrt (pred_oarg : IT.t) clause_packing_ft = | LAT.Constraint (lc, info, lat) -> LRT.Constraint (lc, info, aux lat) | I output -> let loc = Loc.other __FUNCTION__ in - let lc = LC.t_ (IT.eq_ (pred_oarg, output) loc) in + let lc = LC.T (IT.eq_ (pred_oarg, output) loc) in LRT.Constraint (lc, (loc, None), LRT.I) in aux clause_packing_ft @@ -52,6 +52,7 @@ let alloc = let pp_definition def = + let open Pp in item "pointer" (Sym.pp def.pointer) ^/^ item "iargs" (Pp.list (fun (s, _) -> Sym.pp s) def.iargs) ^/^ item "oarg_bt" (BaseTypes.pp def.oarg_bt) @@ -74,9 +75,6 @@ let instantiate_clauses def ptr_arg iargs = | None -> None -open IndexTerms -open LogicalConstraints - let identify_right_clause provable def pointer iargs = match instantiate_clauses def pointer iargs with | None -> @@ -86,11 +84,11 @@ let identify_right_clause provable def pointer iargs = let rec try_clauses = function | [] -> None | clause :: clauses -> - (match provable (t_ clause.guard) with + (match provable (LC.T clause.guard) with | `True -> Some clause | `False -> let loc = Loc.other __FUNCTION__ in - (match provable (t_ (not_ clause.guard loc)) with + (match provable (LC.T (IT.not_ clause.guard loc)) with | `True -> try_clauses clauses | `False -> Pp.debug diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 793e653fb..09d0ad208 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -556,7 +556,7 @@ let model_with_internal loc prop = | None -> let@ prover = provable_internal loc in let here = Locations.other __FUNCTION__ in - (match prover (LC.t_ (IT.not_ prop here)) with + (match prover (LC.T (IT.not_ prop here)) with | `True -> return None | `False -> let@ m = model () in @@ -594,7 +594,7 @@ let bind_logical_return_internal loc = match (members, lrt) with | member :: members, LogicalReturnTypes.Define ((s, it), _, lrt) -> let@ () = ensure_base_type loc ~expect:(IT.bt it) (IT.bt member) in - let@ () = add_c_internal (LC.t_ (IT.eq__ member it loc)) in + let@ () = add_c_internal (LC.T (IT.eq__ member it loc)) in aux members (LogicalReturnTypes.subst (IT.make_subst [ (s, member) ]) lrt) | member :: members, Resource ((s, (re, bt)), _, lrt) -> let@ () = ensure_base_type loc ~expect:bt (IT.bt member) in @@ -798,8 +798,8 @@ let test_value_eqs loc guard x ys = let here = Locations.other __FUNCTION__ in let prop y = match guard with - | None -> LC.t_ (IT.eq_ (x, y) here) - | Some t -> LC.t_ (IT.impl_ (t, IT.eq_ (x, y) here) here) + | None -> LC.T (IT.eq_ (x, y) here) + | Some t -> LC.T (IT.impl_ (t, IT.eq_ (x, y) here) here) in let@ prover = provable loc in let guard_it = Option.value guard ~default:(IT.bool_ true here) in diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index bcf16fdea..4f634c4bf 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -898,7 +898,7 @@ module WIT = struct let@ t1 = infer t1 in pure (let@ () = add_l name (IT.bt t1) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c loc (LC.t_ (IT.def_ name t1 loc)) in + let@ () = add_c loc (LC.T (IT.def_ name t1 loc)) in let@ t2 = infer t2 in return (IT (Let ((name, t1), t2), IT.bt t2, loc))) | Constructor (s, args) -> @@ -1136,7 +1136,7 @@ module WLRT = struct (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ it = WIT.infer it in let@ () = add_l s (IT.bt it) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c (fst info) (LC.t_ (IT.def_ s it here)) in + let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in let@ lrt = aux lrt in return (Define ((s, it), info, lrt)) | Resource ((s, (re, re_oa_spec)), ((loc, _) as info), lrt) -> @@ -1155,7 +1155,7 @@ module WLRT = struct let@ provable = provable loc in let here = Locations.other __FUNCTION__ in let@ () = - match provable (LC.t_ (IT.bool_ false here)) with + match provable (LC.T (IT.bool_ false here)) with | `True -> fail (fun ctxt_log -> { loc; msg = Inconsistent_assumptions ("return type", ctxt_log) }) @@ -1214,7 +1214,7 @@ module WLAT = struct (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ it = WIT.infer it in let@ () = add_l s (IT.bt it) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c (fst info) (LC.t_ (IT.def_ s it here)) in + let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in let@ at = aux at in return (LAT.Define ((s, it), info, at)) | LAT.Resource ((s, (re, re_oa_spec)), ((loc, _) as info), at) -> @@ -1233,7 +1233,7 @@ module WLAT = struct let@ provable = provable loc in let here = Locations.other __FUNCTION__ in let@ () = - match provable (LC.t_ (IT.bool_ false here)) with + match provable (LC.T (IT.bool_ false here)) with | `True -> fail (fun ctxt_log -> { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) @@ -1300,7 +1300,7 @@ module WLArgs = struct (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ it = WIT.infer it in let@ () = add_l s (IT.bt it) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c (fst info) (LC.t_ (IT.def_ s it here)) in + let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in let@ at = aux at in return (Mu.Define ((s, it), info, at)) | Mu.Resource ((s, (re, re_oa_spec)), ((loc, _) as info), at) -> @@ -1319,7 +1319,7 @@ module WLArgs = struct let@ provable = provable loc in let here = Locations.other __FUNCTION__ in let@ () = - match provable (LC.t_ (IT.bool_ false here)) with + match provable (LC.T (IT.bool_ false here)) with | `True -> fail (fun ctxt_log -> { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) @@ -2278,8 +2278,8 @@ module WRPD = struct List.map (fun clause -> IT.not_ clause.guard here) acc in pure - (let@ () = add_c loc (LC.t_ guard) in - let@ () = add_c loc (LC.t_ (IT.and_ negated_guards here)) in + (let@ () = add_c loc (LC.T guard) in + let@ () = add_c loc (LC.T (IT.and_ negated_guards here)) in let@ packing_ft = WLAT.welltyped (fun loc it -> WIT.check loc oarg_bt it) From e3d6ffccd4affb8b7acc98c74cfba27e3523d0de Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 18:00:55 +0000 Subject: [PATCH 097/148] Tidy up Solver --- backend/cn/bin/main.ml | 26 -------------------- backend/cn/lib/check.ml | 9 +++---- backend/cn/lib/diagnostics.ml | 3 +-- backend/cn/lib/explain.ml | 4 ++-- backend/cn/lib/resourceInference.ml | 18 ++++---------- backend/cn/lib/resourceInference.mli | 1 - backend/cn/lib/solver.ml | 12 +--------- backend/cn/lib/solver.mli | 36 +++++----------------------- backend/cn/lib/typing.ml | 6 ++--- 9 files changed, 20 insertions(+), 95 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 69c293034..fc19e0845 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -258,8 +258,6 @@ let verify debug_level print_level print_sym_nums - slow_smt_threshold - slow_smt_dir no_timestamps json json_trace @@ -270,7 +268,6 @@ let verify skip csv_times log_times - random_seed solver_logging solver_flags solver_path @@ -295,8 +292,6 @@ let verify Pp.print_level := print_level; CF.Pp_symbol.pp_cn_sym_nums := print_sym_nums; Pp.print_timestamps := not no_timestamps; - Solver.set_slow_smt_settings slow_smt_threshold slow_smt_dir; - Solver.random_seed := random_seed; (match solver_logging with | Some d -> Solver.Logger.to_file := true; @@ -709,29 +704,11 @@ module Verify_flags = struct Arg.(value & flag & info [ "quiet" ] ~doc) - let slow_smt_threshold = - let doc = "Set the time threshold (in seconds) for logging slow smt queries." in - Arg.(value & opt (some float) None & info [ "slow-smt" ] ~docv:"TIMEOUT" ~doc) - - - let slow_smt_dir = - let doc = - "Set the destination dir for logging slow smt queries (default is in system \ - temp-dir)." - in - Arg.(value & opt (some string) None & info [ "slow-smt-dir" ] ~docv:"FILE" ~doc) - - let diag = let doc = "explore branching diagnostics with key string" in Arg.(value & opt (some string) None & info [ "diag" ] ~doc) - let random_seed = - let doc = "Set the SMT solver random seed (default 1)." in - Arg.(value & opt int 0 & info [ "r"; "random-seed" ] ~docv:"I" ~doc) - - let solver_logging = let doc = "Log solver queries in SMT2 format to a directory." in Arg.(value & opt (some string) None & info [ "solver-logging" ] ~docv:"DIR" ~doc) @@ -880,8 +857,6 @@ let verify_t : unit Term.t = $ Common_flags.debug_level $ Common_flags.print_level $ Common_flags.print_sym_nums - $ Verify_flags.slow_smt_threshold - $ Verify_flags.slow_smt_dir $ Common_flags.no_timestamps $ Verify_flags.json $ Verify_flags.json_trace @@ -892,7 +867,6 @@ let verify_t : unit Term.t = $ Verify_flags.skip $ Common_flags.csv_times $ Common_flags.log_times - $ Verify_flags.random_seed $ Verify_flags.solver_logging $ Verify_flags.solver_flags $ Verify_flags.solver_path diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index d3b100e9d..3bcfe4251 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -312,8 +312,7 @@ let try_prove_constant loc expr = let here = Locations.other __FUNCTION__ in let@ m = model_with loc (IT.bool_ true here) in let@ m = fail_on_none "cannot get model" m in - let@ g = get_global () in - let@ y = fail_on_none "cannot eval term" (Solver.eval g (fst m) expr) in + let@ y = fail_on_none "cannot eval term" (Solver.eval (fst m) expr) in let@ _ = fail_on_none "eval to non-constant term" (IT.is_const y) in let eq = IT.eq_ (expr, y) here in let@ provable = provable loc in @@ -1110,9 +1109,8 @@ let all_empty loc _original_resources = match remaining_resources with | [] -> return () | (resource, constr, model) :: _ -> - let@ global = get_global () in let@ simp_ctxt = simp_ctxt () in - RI.debug_constraint_failure_diagnostics 6 model global simp_ctxt constr; + RI.debug_constraint_failure_diagnostics 6 model simp_ctxt constr; fail (fun ctxt -> (* let ctxt = { ctxt with resources = original_resources } in *) { loc; msg = Unused_resource { resource; ctxt; model } }) @@ -1988,8 +1986,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | `False -> let@ model = model () in let@ simp_ctxt = simp_ctxt () in - let@ global = get_global () in - RI.debug_constraint_failure_diagnostics 6 model global simp_ctxt lc; + RI.debug_constraint_failure_diagnostics 6 model simp_ctxt lc; let@ () = Diagnostics.investigate model lc in fail (fun ctxt -> { loc; diff --git a/backend/cn/lib/diagnostics.ml b/backend/cn/lib/diagnostics.ml index 0c06282c9..d96ce892c 100644 --- a/backend/cn/lib/diagnostics.ml +++ b/backend/cn/lib/diagnostics.ml @@ -47,9 +47,8 @@ let continue_with (opts : opt list) cfg = let term_with_model_name nm cfg x = - let@ g = get_global () in let open Pp in - match Solver.eval g (fst cfg.model) x with + match Solver.eval (fst cfg.model) x with | None -> return (bold nm ^^ colon ^^^ parens (string "cannot eval") ^^ colon ^^^ IT.pp x) | Some r -> diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index 5ba4c9d76..e369fbedc 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -159,7 +159,7 @@ let state ctxt log model_with_q extras = result in let model, quantifier_counter_model = model_with_q in - let evaluate it = Solver.eval ctxt.global model it in + let evaluate it = Solver.eval model it in (* let _mevaluate it = *) (* match evaluate it with *) (* | Some v -> IT.pp v *) @@ -350,7 +350,7 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra :: List.filter_map (function State ctxt -> Some (statef ctxt) | _ -> None) log) in let model, _quantifier_counter_model = model_with_q in - let evaluate it = Solver.eval ctxt.global model it in + let evaluate it = Solver.eval model it in let predicate_hints = match extras.request with | None -> [] diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 43acf24c2..706182772 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -6,7 +6,6 @@ open Typing let debug_constraint_failure_diagnostics lvl (model_with_q : Solver.model_with_q) - global simp_ctxt c = @@ -14,7 +13,7 @@ let debug_constraint_failure_diagnostics if !Pp.print_level == 0 then () else ( - let pp_f = IT.pp_with_eval (Solver.eval global model) in + let pp_f = IT.pp_with_eval (Solver.eval model) in let diag msg c = match (c, model_with_q) with | LC.T tm, _ -> @@ -141,10 +140,9 @@ module General = struct | `True -> return (ftyp, changed_or_deleted) | `False -> let@ model = model () in - let@ global = get_global () in let@ all_cs = get_cs () in let () = assert (not (Context.LC.Set.mem c all_cs)) in - debug_constraint_failure_diagnostics 6 model global simp_ctxt c; + debug_constraint_failure_diagnostics 6 model simp_ctxt c; let@ () = Diagnostics.investigate model c in fail (fun ctxt -> (* let ctxt = { ctxt with resources = original_resources } in *) @@ -184,7 +182,7 @@ module General = struct in let debug_failure model msg term = Pp.debug 9 (lazy (Pp.item msg (Req.pp (fst re)))); - debug_constraint_failure_diagnostics 9 model global simp_ctxt (LC.T term) + debug_constraint_failure_diagnostics 9 model simp_ctxt (LC.T term) in (match provable (LC.T addr_iargs_match) with | `True -> @@ -252,7 +250,6 @@ module General = struct Pp.(debug 7 (lazy (item __FUNCTION__ (Req.pp (Q requested))))); let@ provable = provable loc in let@ simp_ctxt = simp_ctxt () in - let@ global = get_global () in let needed = requested.permission in let step = Simplify.IndexTerms.simp simp_ctxt requested.step in let@ () = @@ -319,12 +316,7 @@ module General = struct Pp.debug 9 (lazy (Pp.item "couldn't use q-resource" (Req.pp (fst re)))); - debug_constraint_failure_diagnostics - 9 - model - global - simp_ctxt - (LC.T pmatch); + debug_constraint_failure_diagnostics 9 model simp_ctxt (LC.T pmatch); continue)) | _re -> continue)) (needed, C []) @@ -386,7 +378,7 @@ module General = struct | `True -> return (Some (oarg, rw_time)) | `False -> let@ model = model () in - debug_constraint_failure_diagnostics 9 model global simp_ctxt nothing_more_needed; + debug_constraint_failure_diagnostics 9 model simp_ctxt nothing_more_needed; return None diff --git a/backend/cn/lib/resourceInference.mli b/backend/cn/lib/resourceInference.mli index 8b5ac6886..785b2f305 100644 --- a/backend/cn/lib/resourceInference.mli +++ b/backend/cn/lib/resourceInference.mli @@ -1,7 +1,6 @@ val debug_constraint_failure_diagnostics : int -> Solver.model_with_q -> - Global.t -> Simplify.simp_ctxt -> LogicalConstraints.logical_constraint -> unit diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 49f2b8362..1e3532709 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -1429,16 +1429,6 @@ let provable ~loc ~solver ~global ~assumptions ~simp_ctxt lc = reason) *) (* ISD: Could these globs be different from the saved ones? *) -let eval _globs mo t = +let eval mo t = let model_fn = Hashtbl.find models_tbl mo in model_fn t - - -(* Dummy implementations *) -let random_seed = ref 0 - -let set_slow_smt_settings _ _ = () - -let debug_solver_to_string _ = () - -let debug_solver_query _ _ _ _ _ = () diff --git a/backend/cn/lib/solver.mli b/backend/cn/lib/solver.mli index 3c11f070e..45f907469 100644 --- a/backend/cn/lib/solver.mli +++ b/backend/cn/lib/solver.mli @@ -8,10 +8,6 @@ type model_with_q = model * (Sym.t * BaseTypes.t) list val empty_model : model -(** Global flags to pass to the solver. Useful for reproducing bugs which only - appear with specific counter-examples. *) -val random_seed : int ref - module Logger : sig val to_file : bool ref @@ -35,7 +31,8 @@ val push : solver -> unit val pop : solver -> int -> unit -(* TODO: BCP: What is this? *) +(** Number of scopes in the solver. Currently only used by [Typing.sandbox], + but may be unnecessary https://github.com/rems-project/cerberus/issues/752 *) val num_scopes : solver -> int (* Run the solver. Note that we pass the assumptions explicitly even though they are also @@ -52,28 +49,7 @@ val provable (* Ask the solver for the model that it found in a call to [provable] *) val model : unit -> model_with_q -(* Ask the solver to evaluate a CN term in the context of a model. (Might return None in - case we ask for the value of a "don't care" value in the (minimal) model.) *) -(* TODO: BCP: I don't understand how this could ever be called -- how do we get a model to - pass it??? *) -val eval - : Global.t -> - (* TODO: BCP: IIUC Christopher thinks this is not needed? *) - model -> - IndexTerms.t -> - IndexTerms.t option - -(* TODO: BCP: What is this? *) -val set_slow_smt_settings : float option -> string option -> unit - -(* Debugging *) -(* TODO: BCP: This one seems misnamed -- it doesn't return a string...? *) -val debug_solver_to_string : solver -> unit - -val debug_solver_query - : solver -> - Global.t -> - Context.LC.Set.t -> - IndexTerms.t list -> - LogicalConstraints.t -> - unit +(** Ask the solver to evaluate a CN term in the context of an already obtained + counter-example model (e.g. for evaluating sub-terms). Might return None in + case we ask for the value of a "don't care" value in the (minimal) model. *) +val eval : model -> IndexTerms.t -> IndexTerms.t option diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 09d0ad208..c4f74ef25 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -496,9 +496,8 @@ let get_just_models () = let model_has_prop () = - let@ global = get_global () in let is_some_true t = Option.is_some t && IT.is_true (Option.get t) in - return (fun prop m -> is_some_true (Solver.eval global (fst m) prop)) + return (fun prop m -> is_some_true (Solver.eval (fst m) prop)) let prove_or_model_with_past_model loc m = @@ -518,7 +517,6 @@ let prove_or_model_with_past_model loc m = let do_check_model loc m prop = Pp.warn loc (Pp.string "doing model consistency check"); let@ ctxt = get_typing_context () in - let@ global = get_global () in let vs = Context.( Sym.Map.bindings ctxt.computational @ Sym.Map.bindings ctxt.logical @@ -529,7 +527,7 @@ let do_check_model loc m prop = let eqs = List.filter_map (fun v -> - match Solver.eval global (fst m) v with + match Solver.eval (fst m) v with | None -> None | Some x -> Some (IT.eq_ (v, x) here)) vs From 4b8da9e294170e95a4e7f171f650a26602c775c7 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 18:25:15 +0000 Subject: [PATCH 098/148] Put resource predicate records in modules --- backend/cn/lib/cn_internal_to_ail.ml | 12 +- backend/cn/lib/cn_internal_to_ail.mli | 12 +- backend/cn/lib/compile.ml | 15 +- backend/cn/lib/executable_spec_internal.ml | 4 +- backend/cn/lib/executable_spec_records.ml | 2 +- backend/cn/lib/explain.ml | 8 +- backend/cn/lib/global.ml | 4 +- backend/cn/lib/mucore.ml | 2 +- backend/cn/lib/mucore.mli | 2 +- backend/cn/lib/pack.ml | 4 +- backend/cn/lib/request.ml | 1 - backend/cn/lib/resourcePredicates.ml | 140 ++++++++++--------- backend/cn/lib/testGeneration/genAnalysis.ml | 6 +- backend/cn/lib/testGeneration/genCompile.ml | 14 +- backend/cn/lib/testGeneration/genCompile.mli | 2 +- backend/cn/lib/typing.mli | 4 +- backend/cn/lib/wellTyped.ml | 10 +- 17 files changed, 123 insertions(+), 119 deletions(-) diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index b628a54bc..577f4da42 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -2563,7 +2563,7 @@ let cn_to_ail_resource_internal sym dts globals - (preds : (Sym.t * RP.definition) list) + (preds : (Sym.t * RP.Definition.t) list) _loc = let calculate_return_type = function @@ -3024,14 +3024,14 @@ let rec cn_to_ail_lat_internal ?(is_toplevel = true) dts pred_sym_opt globals pr let cn_to_ail_predicate_internal - (pred_sym, (rp_def : ResourcePredicates.definition)) + (pred_sym, (rp_def : RP.Definition.t)) dts globals preds cn_preds = let ret_type = bt_to_ail_ctype ~pred_sym:(Some pred_sym) rp_def.oarg_bt in - let rec clause_translate (clauses : RP.clause list) = + let rec clause_translate (clauses : RP.Clause.t list) = match clauses with | [] -> ([], []) | c :: cs -> @@ -3531,7 +3531,7 @@ let cn_to_ail_assume_resource_internal sym dts globals - (preds : (Sym.t * RP.definition) list) + (preds : (Sym.t * RP.Definition.t) list) loc = let calculate_return_type = function @@ -3835,13 +3835,13 @@ let rec cn_to_ail_assume_lat_internal dts pred_sym_opt globals preds = function let cn_to_ail_assume_predicate_internal - (pred_sym, (rp_def : ResourcePredicates.definition)) + (pred_sym, (rp_def : RP.Definition.t)) dts globals preds = let ret_type = bt_to_ail_ctype ~pred_sym:(Some pred_sym) rp_def.oarg_bt in - let rec clause_translate (clauses : RP.clause list) = + let rec clause_translate (clauses : RP.Clause.t list) = match clauses with | [] -> ([], []) | c :: cs -> diff --git a/backend/cn/lib/cn_internal_to_ail.mli b/backend/cn/lib/cn_internal_to_ail.mli index 4a600fc7f..dd7b62d9b 100644 --- a/backend/cn/lib/cn_internal_to_ail.mli +++ b/backend/cn/lib/cn_internal_to_ail.mli @@ -156,10 +156,10 @@ val cn_to_ail_function_internal * A.sigma_tag_definition option val cn_to_ail_predicates_internal - : (Sym.t * ResourcePredicates.definition) list -> + : (Sym.t * ResourcePredicates.Definition.t) list -> A.sigma_cn_datatype list -> (Sym.t * C.ctype) list -> - (Sym.t * ResourcePredicates.definition) list -> + (Sym.t * ResourcePredicates.Definition.t) list -> A.sigma_cn_predicate list -> ((Locations.t * A.sigma_declaration) * CF.GenTypes.genTypeCategory A.sigma_function_definition) @@ -169,17 +169,17 @@ val cn_to_ail_predicates_internal val cn_to_ail_pre_post_internal : without_ownership_checking:bool -> A.sigma_cn_datatype list -> - (Sym.t * ResourcePredicates.definition) list -> + (Sym.t * ResourcePredicates.Definition.t) list -> (Sym.t * C.ctype) list -> C.ctype -> Executable_spec_extract.fn_args_and_body option -> ail_executable_spec val cn_to_ail_assume_predicates_internal - : (Sym.t * ResourcePredicates.definition) list -> + : (Sym.t * ResourcePredicates.Definition.t) list -> A.sigma_cn_datatype list -> (Sym.t * C.ctype) list -> - (Sym.t * ResourcePredicates.definition) list -> + (Sym.t * ResourcePredicates.Definition.t) list -> (A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition) list val cn_to_ail_assume_pre_internal @@ -187,6 +187,6 @@ val cn_to_ail_assume_pre_internal C.union_tag -> (C.union_tag * (BT.t * C.ctype)) list -> (C.union_tag * C.ctype) list -> - (C.union_tag * ResourcePredicates.definition) list -> + (C.union_tag * ResourcePredicates.Definition.t) list -> 'a LogicalArgumentTypes.t -> A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 5913af58c..c1557d032 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -1374,7 +1374,7 @@ let translate_cn_clauses env clauses = | CN_clause (loc, cl_) -> let@ cl = translate_cn_clause env cl_ in let here = Locations.other __FUNCTION__ in - return (RP.{ loc; guard = IT.bool_ true here; packing_ft = cl } :: acc) + return (RP.Clause.{ loc; guard = IT.bool_ true here; packing_ft = cl } :: acc) | CN_if (loc, e_, cl_, clauses') -> let@ e = Pure.handle "Predicate guards" (ET.translate_cn_expr Sym.Set.empty env e_) @@ -1409,12 +1409,13 @@ let translate_cn_predicate env (def : cn_predicate) = | (iarg0, BaseTypes.Loc ()) :: iargs' -> return ( def.cn_pred_name, - { loc = def.cn_pred_loc; - pointer = iarg0; - iargs = iargs'; - oarg_bt = output_bt; - clauses - } ) + Definition. + { loc = def.cn_pred_loc; + pointer = iarg0; + iargs = iargs'; + oarg_bt = output_bt; + clauses + } ) | (_, found_bty) :: _ -> fail { loc = def.cn_pred_loc; diff --git a/backend/cn/lib/executable_spec_internal.ml b/backend/cn/lib/executable_spec_internal.ml index 2c390f528..d3d889884 100644 --- a/backend/cn/lib/executable_spec_internal.ml +++ b/backend/cn/lib/executable_spec_internal.ml @@ -360,7 +360,7 @@ let fns_and_preds_with_record_rt (funs, preds) = let fun_syms = List.map (fun (fn_sym, _) -> fn_sym) funs' in let preds' = List.filter - (fun (_, (def : ResourcePredicates.definition)) -> + (fun (_, (def : ResourcePredicates.Definition.t)) -> bt_is_record_or_tuple def.oarg_bt) preds in @@ -440,7 +440,7 @@ let rec remove_duplicates eq_fun = function let generate_c_predicates_internal (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) - (resource_predicates : (Sym.t * ResourcePredicates.definition) list) + (resource_predicates : (Sym.t * ResourcePredicates.Definition.t) list) = (* let ail_info = List.map (fun cn_f -> Cn_internal_to_ail.cn_to_ail_predicate_internal cn_f sigm.cn_datatypes [] ownership_ctypes resource_predicates) resource_predicates diff --git a/backend/cn/lib/executable_spec_records.ml b/backend/cn/lib/executable_spec_records.ml index 4dbd181ab..13022fe47 100644 --- a/backend/cn/lib/executable_spec_records.ml +++ b/backend/cn/lib/executable_spec_records.ml @@ -146,7 +146,7 @@ let add_records_to_map_from_fns_and_preds cn_funs cn_preds = in let pred_syms_and_ret_types = List.map - (fun (sym, (def : ResourcePredicates.definition)) -> (sym, def.oarg_bt)) + (fun (sym, (def : ResourcePredicates.Definition.t)) -> (sym, def.oarg_bt)) cn_preds in List.iter diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index e369fbedc..e0b8df710 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -39,17 +39,15 @@ let clause_has_resource req c = | Define (_, _, c) -> f c | I _ -> false in - let open ResourcePredicates in - f c.packing_ft + f c.REP.Clause.packing_ft let relevant_predicate_clauses global name req = let open Global in - let open ResourcePredicates in let clauses = let defs = Sym.Map.bindings global.resource_predicates in List.concat_map - (fun (nm, def) -> + (fun (nm, (def : REP.Definition.t)) -> match def.clauses with | Some clauses -> List.map (fun c -> (nm, c)) clauses | None -> []) @@ -360,7 +358,7 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra | Owned _ -> [] | PName pname -> let doc_clause (_name, c) = - { cond = IT.pp c.guard; + { cond = IT.pp c.REP.Clause.guard; clause = LogicalArgumentTypes.pp IT.pp (simp_resource evaluate c.packing_ft) } in diff --git a/backend/cn/lib/global.ml b/backend/cn/lib/global.ml index c5bbe40e6..04c624646 100644 --- a/backend/cn/lib/global.ml +++ b/backend/cn/lib/global.ml @@ -9,7 +9,7 @@ type t = datatype_constrs : BaseTypes.constr_info Sym.Map.t; datatype_order : Sym.t list list option; fun_decls : (Locations.t * AT.ft option * Sctypes.c_concrete_sig) Sym.Map.t; - resource_predicates : ResourcePredicates.definition Sym.Map.t; + resource_predicates : ResourcePredicates.Definition.t Sym.Map.t; logical_functions : LogicalFunctions.definition Sym.Map.t; lemmata : (Locations.t * AT.lemmat) Sym.Map.t } @@ -68,7 +68,7 @@ let pp_fun_decls decls = flow_map hardline pp_fun_decl (Sym.Map.bindings decls) let pp_resource_predicate_definitions defs = separate_map hardline - (fun (name, def) -> item (Sym.pp_string name) (ResourcePredicates.pp_definition def)) + (fun (name, def) -> item (Sym.pp_string name) (ResourcePredicates.Definition.pp def)) (Sym.Map.bindings defs) diff --git a/backend/cn/lib/mucore.ml b/backend/cn/lib/mucore.ml index b05e191af..2ab7227b9 100644 --- a/backend/cn/lib/mucore.ml +++ b/backend/cn/lib/mucore.ml @@ -428,7 +428,7 @@ type 'TY file = extern : Cerb_frontend.Core.extern_map; stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; - resource_predicates : (Sym.t * ResourcePredicates.definition) list; + resource_predicates : (Sym.t * ResourcePredicates.Definition.t) list; logical_predicates : (Sym.t * LogicalFunctions.definition) list; datatypes : (Sym.t * datatype) list; lemmata : (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list; diff --git a/backend/cn/lib/mucore.mli b/backend/cn/lib/mucore.mli index 03a1987f4..d3b657d68 100644 --- a/backend/cn/lib/mucore.mli +++ b/backend/cn/lib/mucore.mli @@ -331,7 +331,7 @@ type 'TY file = extern : Cerb_frontend.Core.extern_map; stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; - resource_predicates : (Sym.t * ResourcePredicates.definition) list; + resource_predicates : (Sym.t * ResourcePredicates.Definition.t) list; logical_predicates : (Sym.t * LogicalFunctions.definition) list; datatypes : (Sym.t * datatype) list; lemmata : (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list; diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index cb5eff088..02266cb98 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -4,6 +4,8 @@ open ResourcePredicates open Memory module IT = IndexTerms module LAT = LogicalArgumentTypes +module LRT = LogicalReturnTypes +module LC = LogicalConstraints (* open Cerb_pp_prelude *) @@ -141,7 +143,7 @@ let unpack loc global provable (ret, O o) = | _ -> (match packing_ft loc global provable ret with | None -> None - | Some packing_ft -> Some (`LRT (ResourcePredicates.clause_lrt o packing_ft))) + | Some packing_ft -> Some (`LRT (ResourcePredicates.Clause.lrt o packing_ft))) let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O o) = diff --git a/backend/cn/lib/request.ml b/backend/cn/lib/request.ml index 27c41e3bd..d274abb33 100644 --- a/backend/cn/lib/request.ml +++ b/backend/cn/lib/request.ml @@ -1,7 +1,6 @@ open Pp.Infix module IT = IndexTerms -(* TODO move this? *) let pp_maybe_oargs = function None -> Pp.empty | Some oargs -> Pp.parens (IT.pp oargs) type init = diff --git a/backend/cn/lib/resourcePredicates.ml b/backend/cn/lib/resourcePredicates.ml index ec970e646..6e6fa48eb 100644 --- a/backend/cn/lib/resourcePredicates.ml +++ b/backend/cn/lib/resourcePredicates.ml @@ -1,69 +1,73 @@ module IT = IndexTerms -module LRT = LogicalReturnTypes -module LC = LogicalConstraints -module AT = ArgumentTypes module LAT = LogicalArgumentTypes -module StringMap = Map.Make (String) -module Loc = Locations -type clause = - { loc : Loc.t; - guard : IT.t; - packing_ft : LAT.packing_ft - } - -let pp_clause { loc = _; guard; packing_ft } = - let open Pp in - item "condition" (IT.pp guard) ^^ comma ^^^ item "return type" (LAT.pp IT.pp packing_ft) - - -let subst_clause subst { loc; guard; packing_ft } = - { loc; guard = IT.subst subst guard; packing_ft = LAT.subst IT.subst subst packing_ft } - - -let clause_lrt (pred_oarg : IT.t) clause_packing_ft = - let rec aux = function - | LAT.Define (bound, info, lat) -> LRT.Define (bound, info, aux lat) - | LAT.Resource (bound, info, lat) -> LRT.Resource (bound, info, aux lat) - | LAT.Constraint (lc, info, lat) -> LRT.Constraint (lc, info, aux lat) - | I output -> - let loc = Loc.other __FUNCTION__ in - let lc = LC.T (IT.eq_ (pred_oarg, output) loc) in - LRT.Constraint (lc, (loc, None), LRT.I) - in - aux clause_packing_ft +module Clause = struct + type t = + { loc : Locations.t; + guard : IT.t; + packing_ft : LAT.packing_ft + } + + let pp { loc = _; guard; packing_ft } = + let open Pp in + item "condition" (IT.pp guard) + ^^ comma + ^^^ item "return type" (LAT.pp IT.pp packing_ft) + + + let subst subst { loc; guard; packing_ft } = + { loc; + guard = IT.subst subst guard; + packing_ft = LAT.subst IT.subst subst packing_ft + } + + + let lrt (pred_oarg : IT.t) clause_packing_ft = + let module LRT = LogicalReturnTypes in + let rec aux = function + | LAT.Define (bound, info, lat) -> LRT.Define (bound, info, aux lat) + | LAT.Resource (bound, info, lat) -> LRT.Resource (bound, info, aux lat) + | LAT.Constraint (lc, info, lat) -> LRT.Constraint (lc, info, aux lat) + | I output -> + let loc = Locations.other __FUNCTION__ in + let lc = LogicalConstraints.T (IT.eq_ (pred_oarg, output) loc) in + LRT.Constraint (lc, (loc, None), LRT.I) + in + aux clause_packing_ft +end + +module Definition = struct + type t = + { loc : Locations.t; + pointer : Sym.t; + iargs : (Sym.t * BaseTypes.t) list; + oarg_bt : BaseTypes.t; + clauses : Clause.t list option + } + + let pp def = + let open Pp in + item "pointer" (Sym.pp def.pointer) + ^/^ item "iargs" (Pp.list (fun (s, _) -> Sym.pp s) def.iargs) + ^/^ item "oarg_bt" (BaseTypes.pp def.oarg_bt) + ^/^ item + "clauses" + (match def.clauses with + | Some clauses -> Pp.list Clause.pp clauses + | None -> !^"(uninterpreted)") +end +let alloc = + Definition. + { loc = Locations.other (__FILE__ ^ ":" ^ string_of_int __LINE__); + pointer = Sym.fresh_named "ptr"; + iargs = []; + oarg_bt = Alloc.History.value_bt; + clauses = None + } -type definition = - { loc : Loc.t; - pointer : Sym.t; - iargs : (Sym.t * BaseTypes.t) list; - oarg_bt : BaseTypes.t; - clauses : clause list option - } -let alloc = - { loc = Locations.other (__FILE__ ^ ":" ^ string_of_int __LINE__); - pointer = Sym.fresh_named "ptr"; - iargs = []; - oarg_bt = Alloc.History.value_bt; - clauses = None - } - - -let pp_definition def = - let open Pp in - item "pointer" (Sym.pp def.pointer) - ^/^ item "iargs" (Pp.list (fun (s, _) -> Sym.pp s) def.iargs) - ^/^ item "oarg_bt" (BaseTypes.pp def.oarg_bt) - ^/^ item - "clauses" - (match def.clauses with - | Some clauses -> Pp.list pp_clause clauses - | None -> !^"(uninterpreted)") - - -let instantiate_clauses def ptr_arg iargs = +let instantiate_clauses (def : Definition.t) ptr_arg iargs = match def.clauses with | Some clauses -> let subst = @@ -71,24 +75,24 @@ let instantiate_clauses def ptr_arg iargs = ((def.pointer, ptr_arg) :: List.map2 (fun (def_ia, _) ia -> (def_ia, ia)) def.iargs iargs) in - Some (List.map (subst_clause subst) clauses) + Some (List.map (Clause.subst subst) clauses) | None -> None -let identify_right_clause provable def pointer iargs = +let identify_right_clause provable (def : Definition.t) pointer iargs = match instantiate_clauses def pointer iargs with | None -> (* "uninterpreted" predicates cannot be un/packed *) None | Some clauses -> - let rec try_clauses = function + let rec try_clauses : Clause.t list -> _ = function | [] -> None | clause :: clauses -> - (match provable (LC.T clause.guard) with + (match provable (LogicalConstraints.T clause.guard) with | `True -> Some clause | `False -> - let loc = Loc.other __FUNCTION__ in - (match provable (LC.T (IT.not_ clause.guard loc)) with + let loc = Locations.other __FUNCTION__ in + (match provable (LogicalConstraints.T (IT.not_ clause.guard loc)) with | `True -> try_clauses clauses | `False -> Pp.debug @@ -102,7 +106,7 @@ let identify_right_clause provable def pointer iargs = (* determines if a resource predicate will be given to the solver TODO: right now this is an overapproximation *) -let given_to_solver def = +let given_to_solver (def : Definition.t) = match def.clauses with | None -> false | Some [] -> true @@ -111,4 +115,4 @@ let given_to_solver def = (*Extensibility hook. For now, all predicates are displayed as "interesting" in error reporting*) -let is_interesting : definition -> bool = fun _ -> true +let is_interesting : Definition.t -> bool = fun _ -> true diff --git a/backend/cn/lib/testGeneration/genAnalysis.ml b/backend/cn/lib/testGeneration/genAnalysis.ml index f3d32b69e..3be7175ea 100644 --- a/backend/cn/lib/testGeneration/genAnalysis.ml +++ b/backend/cn/lib/testGeneration/genAnalysis.ml @@ -150,11 +150,11 @@ end let get_bounds = Bounds.get_bounds -let get_recursive_preds (preds : (Sym.t * RP.definition) list) : Sym.Set.t = - let get_calls (pred : RP.definition) : Sym.Set.t = +let get_recursive_preds (preds : (Sym.t * RP.Definition.t) list) : Sym.Set.t = + let get_calls (pred : RP.Definition.t) : Sym.Set.t = pred.clauses |> Option.get - |> List.map (fun (cl : RP.clause) -> cl.packing_ft) + |> List.map (fun (cl : RP.Clause.t) -> cl.packing_ft) |> List.map LAT.r_resource_requests |> List.flatten |> List.map snd diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index 089f2ca2b..1a4432380 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -33,7 +33,7 @@ let compile_oargs (ret_bt : BT.t) (iargs : (Sym.t * BT.t) list) : (Sym.t * BT.t) let add_request (recursive : Sym.Set.t) - (preds : (Sym.Map.key * RP.definition) list) + (preds : (Sym.Map.key * RP.Definition.t) list) (fsym : Sym.t) : unit m = @@ -99,7 +99,7 @@ let compile_vars (generated : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) (lat : I let rec compile_it_lat (filename : string) (recursive : Sym.Set.t) - (preds : (Sym.t * RP.definition) list) + (preds : (Sym.t * RP.Definition.t) list) (name : Sym.t) (generated : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) @@ -270,11 +270,11 @@ let rec compile_it_lat let rec compile_clauses (filename : string) (recursive : Sym.Set.t) - (preds : (Sym.t * RP.definition) list) + (preds : (Sym.t * RP.Definition.t) list) (name : Sym.t) (iargs : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) - (cls : RP.clause list) + (cls : RP.Clause.t list) : GT.t m = match cls with @@ -293,7 +293,7 @@ let rec compile_clauses let compile_pred (recursive_preds : Sym.Set.t) - (preds : (Sym.t * RP.definition) list) + (preds : (Sym.t * RP.Definition.t) list) ({ filename; recursive; spec; name; iargs; oargs; body } : GD.t) : unit m = @@ -316,7 +316,7 @@ let compile_pred let compile_spec (filename : string) (recursive : Sym.Set.t) - (preds : (Sym.t * RP.definition) list) + (preds : (Sym.t * RP.Definition.t) list) (name : Sym.t) (at : 'a AT.t) : unit m @@ -374,7 +374,7 @@ let compile_spec let compile ?(ctx : GD.context option) - (preds : (Sym.t * RP.definition) list) + (preds : (Sym.t * RP.Definition.t) list) (insts : Executable_spec_extract.instrumentation list) : GD.context = diff --git a/backend/cn/lib/testGeneration/genCompile.mli b/backend/cn/lib/testGeneration/genCompile.mli index 4f4f2ce22..a48289926 100644 --- a/backend/cn/lib/testGeneration/genCompile.mli +++ b/backend/cn/lib/testGeneration/genCompile.mli @@ -1,5 +1,5 @@ val compile : ?ctx:GenDefinitions.context -> - (Sym.t * ResourcePredicates.definition) list -> + (Sym.t * ResourcePredicates.Definition.t) list -> Executable_spec_extract.instrumentation list -> GenDefinitions.context diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 1171dc4c8..394222b38 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -116,7 +116,7 @@ val get_fun_decl val get_lemma : Locations.t -> Sym.t -> (Locations.t * Global.AT.lemmat) m -val get_resource_predicate_def : Locations.t -> Sym.t -> ResourcePredicates.definition m +val get_resource_predicate_def : Locations.t -> Sym.t -> ResourcePredicates.Definition.t m val get_logical_function_def : Locations.t -> Sym.t -> LogicalFunctions.definition m @@ -129,7 +129,7 @@ val add_fun_decl val add_lemma : Sym.t -> Locations.t * ArgumentTypes.lemmat -> unit m -val add_resource_predicate : Sym.t -> ResourcePredicates.definition -> unit m +val add_resource_predicate : Sym.t -> ResourcePredicates.Definition.t -> unit m val add_logical_function : Sym.t -> LogicalFunctions.definition -> unit m diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 4f634c4bf..d2491937f 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -2252,7 +2252,7 @@ end module WRPD = struct open ResourcePredicates - let welltyped { loc; pointer; iargs; oarg_bt; clauses } = + let welltyped Definition.{ loc; pointer; iargs; oarg_bt; clauses } = (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure (let@ () = add_l pointer BT.(Loc ()) (loc, lazy (Pp.string "ptr-var")) in @@ -2271,11 +2271,11 @@ module WRPD = struct | Some clauses -> let@ clauses = ListM.fold_leftM - (fun acc { loc; guard; packing_ft } -> + (fun acc Clause.{ loc; guard; packing_ft } -> let@ guard = WIT.check loc BT.Bool guard in let here = Locations.other __FUNCTION__ in let negated_guards = - List.map (fun clause -> IT.not_ clause.guard here) acc + List.map (fun clause -> IT.not_ clause.Clause.guard here) acc in pure (let@ () = add_c loc (LC.T guard) in @@ -2288,13 +2288,13 @@ module WRPD = struct loc packing_ft in - return (acc @ [ { loc; guard; packing_ft } ]))) + return (acc @ [ Clause.{ loc; guard; packing_ft } ]))) [] clauses in return (Some clauses) in - return { loc; pointer; iargs; oarg_bt; clauses }) + return Definition.{ loc; pointer; iargs; oarg_bt; clauses }) end module WLFD = struct From 92ab70257c316dc394529e3ffded1e98f578b13d Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 18:41:56 +0000 Subject: [PATCH 099/148] Combine function and predicate definitions --- backend/cn/lib/cLogicalFuns.ml | 10 +- backend/cn/lib/check.ml | 4 +- backend/cn/lib/cn_internal_to_ail.ml | 14 +- backend/cn/lib/cn_internal_to_ail.mli | 14 +- backend/cn/lib/compile.ml | 29 ++- backend/cn/lib/context.ml | 4 +- backend/cn/lib/definition.ml | 223 +++++++++++++++++++ backend/cn/lib/executable_spec_internal.ml | 9 +- backend/cn/lib/executable_spec_records.ml | 6 +- backend/cn/lib/explain.ml | 14 +- backend/cn/lib/global.ml | 9 +- backend/cn/lib/lemmata.ml | 10 +- backend/cn/lib/logicalFunctions.ml | 107 --------- backend/cn/lib/mucore.ml | 4 +- backend/cn/lib/mucore.mli | 4 +- backend/cn/lib/pack.ml | 4 +- backend/cn/lib/resourcePredicates.ml | 118 ---------- backend/cn/lib/simplify.ml | 2 +- backend/cn/lib/solver.ml | 2 +- backend/cn/lib/testGeneration/genAnalysis.ml | 8 +- backend/cn/lib/testGeneration/genCompile.ml | 16 +- backend/cn/lib/testGeneration/genCompile.mli | 2 +- backend/cn/lib/typing.mli | 8 +- backend/cn/lib/wellTyped.ml | 19 +- 24 files changed, 316 insertions(+), 324 deletions(-) create mode 100644 backend/cn/lib/definition.ml delete mode 100644 backend/cn/lib/logicalFunctions.ml delete mode 100644 backend/cn/lib/resourcePredicates.ml diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index 823f3ca7d..b805031f6 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -542,7 +542,7 @@ let rec symb_exec_expr ctxt state_vars expr = if Sym.Map.mem nm ctxt.c_fun_pred_map then ( let loc, l_sym = Sym.Map.find nm ctxt.c_fun_pred_map in let@ def = get_logical_function_def loc l_sym in - rcval (IT.apply_ l_sym args_its def.LogicalFunctions.return_bt loc) state) + rcval (IT.apply_ l_sym args_its def.Definition.Function.return_bt loc) state) else ( let bail = fail_fun_it "not a function with a pure/logical interpretation" in match Sym.has_id nm with @@ -621,7 +621,7 @@ let rec get_ret_it loc body bt = function let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_decl) = let here = Locations.other __FUNCTION__ in let def_args = - def.LogicalFunctions.args + def.Definition.Function.args (* TODO - add location information to binders *) |> List.map (fun (s, bt) -> IndexTerms.sym_ (s, bt, here)) in @@ -678,7 +678,7 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ let@ () = match rt with | ReturnTypes.Computational ((_, bt), _, _) -> - let l_ret_bt = def.LogicalFunctions.return_bt in + let l_ret_bt = def.Definition.Function.return_bt in if BT.equal bt l_ret_bt then return () else @@ -702,7 +702,7 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ (WellTyped.BaseTyping.infer_expr label_context body)) in let@ r = symb_exec_expr ctxt (init_state, arg_map) body in - let@ it = get_ret_it loc body def.LogicalFunctions.return_bt r in + let@ it = get_ret_it loc body def.Definition.Function.return_bt r in simp_const loc (lazy (Pp_mucore.pp_expr body)) it | _ -> fail_n @@ -712,7 +712,7 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ let upd_def (loc, sym, def_tm) = - let open LogicalFunctions in + let open Definition.Function in let@ def = get_logical_function_def loc sym in match def.definition with | Uninterp -> add_logical_function sym { def with definition = Def def_tm } diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 3bcfe4251..b9fd514d1 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -1958,7 +1958,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = args def.args in - (match LogicalFunctions.unroll_once def args with + (match Definition.Function.unroll_once def args with | None -> let msg = !^"Cannot unfold definition of uninterpreted function" ^^^ Sym.pp f ^^ dot @@ -2222,7 +2222,7 @@ let check_tagdefs tagDefs = let record_and_check_logical_functions funs = let recursive, _nonrecursive = - List.partition (fun (_, def) -> LogicalFunctions.is_recursive def) funs + List.partition (fun (_, def) -> Definition.Function.is_recursive def) funs in let n_funs = List.length funs in (* Add all recursive functions (without their actual bodies), so that they diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 577f4da42..ac88aa73f 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -2563,7 +2563,7 @@ let cn_to_ail_resource_internal sym dts globals - (preds : (Sym.t * RP.Definition.t) list) + (preds : (Sym.t * Def.Predicate.t) list) _loc = let calculate_return_type = function @@ -2932,7 +2932,7 @@ let rec generate_record_opt pred_sym = function (* TODO: Finish with rest of function - maybe header file with A.Decl_function (cn.h?) *) let cn_to_ail_function_internal - (fn_sym, (lf_def : LogicalFunctions.definition)) + (fn_sym, (lf_def : Definition.Function.definition)) (cn_datatypes : A.sigma_cn_datatype list) (cn_functions : A.sigma_cn_function list) : ((Locations.t * A.sigma_declaration) @@ -3024,14 +3024,14 @@ let rec cn_to_ail_lat_internal ?(is_toplevel = true) dts pred_sym_opt globals pr let cn_to_ail_predicate_internal - (pred_sym, (rp_def : RP.Definition.t)) + (pred_sym, (rp_def : Def.Predicate.t)) dts globals preds cn_preds = let ret_type = bt_to_ail_ctype ~pred_sym:(Some pred_sym) rp_def.oarg_bt in - let rec clause_translate (clauses : RP.Clause.t list) = + let rec clause_translate (clauses : Def.Clause.t list) = match clauses with | [] -> ([], []) | c :: cs -> @@ -3531,7 +3531,7 @@ let cn_to_ail_assume_resource_internal sym dts globals - (preds : (Sym.t * RP.Definition.t) list) + (preds : (Sym.t * Def.Predicate.t) list) loc = let calculate_return_type = function @@ -3835,13 +3835,13 @@ let rec cn_to_ail_assume_lat_internal dts pred_sym_opt globals preds = function let cn_to_ail_assume_predicate_internal - (pred_sym, (rp_def : RP.Definition.t)) + (pred_sym, (rp_def : Def.Predicate.t)) dts globals preds = let ret_type = bt_to_ail_ctype ~pred_sym:(Some pred_sym) rp_def.oarg_bt in - let rec clause_translate (clauses : RP.Clause.t list) = + let rec clause_translate (clauses : Def.Clause.t list) = match clauses with | [] -> ([], []) | c :: cs -> diff --git a/backend/cn/lib/cn_internal_to_ail.mli b/backend/cn/lib/cn_internal_to_ail.mli index dd7b62d9b..0840c8515 100644 --- a/backend/cn/lib/cn_internal_to_ail.mli +++ b/backend/cn/lib/cn_internal_to_ail.mli @@ -148,7 +148,7 @@ val cn_to_ail_records A.sigma_tag_definition list val cn_to_ail_function_internal - : Sym.t * LogicalFunctions.definition -> + : Sym.t * Definition.Function.definition -> A.sigma_cn_datatype list -> A.sigma_cn_function list -> ((Locations.t * A.sigma_declaration) @@ -156,10 +156,10 @@ val cn_to_ail_function_internal * A.sigma_tag_definition option val cn_to_ail_predicates_internal - : (Sym.t * ResourcePredicates.Definition.t) list -> + : (Sym.t * Definition.Predicate.t) list -> A.sigma_cn_datatype list -> (Sym.t * C.ctype) list -> - (Sym.t * ResourcePredicates.Definition.t) list -> + (Sym.t * Definition.Predicate.t) list -> A.sigma_cn_predicate list -> ((Locations.t * A.sigma_declaration) * CF.GenTypes.genTypeCategory A.sigma_function_definition) @@ -169,17 +169,17 @@ val cn_to_ail_predicates_internal val cn_to_ail_pre_post_internal : without_ownership_checking:bool -> A.sigma_cn_datatype list -> - (Sym.t * ResourcePredicates.Definition.t) list -> + (Sym.t * Definition.Predicate.t) list -> (Sym.t * C.ctype) list -> C.ctype -> Executable_spec_extract.fn_args_and_body option -> ail_executable_spec val cn_to_ail_assume_predicates_internal - : (Sym.t * ResourcePredicates.Definition.t) list -> + : (Sym.t * Definition.Predicate.t) list -> A.sigma_cn_datatype list -> (Sym.t * C.ctype) list -> - (Sym.t * ResourcePredicates.Definition.t) list -> + (Sym.t * Definition.Predicate.t) list -> (A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition) list val cn_to_ail_assume_pre_internal @@ -187,6 +187,6 @@ val cn_to_ail_assume_pre_internal C.union_tag -> (C.union_tag * (BT.t * C.ctype)) list -> (C.union_tag * C.ctype) list -> - (C.union_tag * ResourcePredicates.Definition.t) list -> + (C.union_tag * Definition.Predicate.t) list -> 'a LogicalArgumentTypes.t -> A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index c1557d032..4424446d8 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -1,7 +1,7 @@ module CF = Cerb_frontend module SBT = BaseTypes.Surface module BT = BaseTypes -module RP = ResourcePredicates +module Def = Definition module IT = IndexTerms module LAT = LogicalArgumentTypes module LRT = LogicalReturnTypes @@ -39,7 +39,7 @@ type env = } let init_env tagDefs fetch_enum_expr fetch_typedef = - let alloc_sig = { pred_iargs = []; pred_output = ResourcePredicates.alloc.oarg_bt } in + let alloc_sig = { pred_iargs = []; pred_output = Definition.alloc.oarg_bt } in { computationals = Sym.Map.empty; logicals = Sym.Map.(empty |> add Alloc.History.sym Alloc.History.sbt); predicates = Sym.Map.(empty |> add Alloc.Predicate.sym alloc_sig); @@ -1197,7 +1197,6 @@ let translate_cn_func_body env body = let known_attrs = [ "rec"; "coq_unfold" ] let translate_cn_function env (def : cn_function) = - let open LogicalFunctions in Pp.debug 2 (lazy (Pp.item "translating function defn" (Sym.pp def.cn_func_name))); let args = List.map (fun (sym, bTy) -> (sym, translate_cn_base_type env bTy)) def.cn_func_args @@ -1223,17 +1222,18 @@ let translate_cn_function env (def : cn_function) = match def.cn_func_body with | Some body -> let@ body = translate_cn_func_body env' body in - return (if is_rec then Rec_Def body else Def body) - | None -> return Uninterp + return (if is_rec then Def.Function.Rec_Def body else Def.Function.Def body) + | None -> return Def.Function.Uninterp in let return_bt = translate_cn_base_type env def.cn_func_return_bty in let def2 = - { loc = def.cn_func_loc; - args = List.map_snd SBT.proj args; - return_bt = SBT.proj return_bt; - emit_coq = not coq_unfold; - definition - } + Def.Function. + { loc = def.cn_func_loc; + args = List.map_snd SBT.proj args; + return_bt = SBT.proj return_bt; + emit_coq = not coq_unfold; + definition + } in return (def.cn_func_name, def2) @@ -1374,13 +1374,13 @@ let translate_cn_clauses env clauses = | CN_clause (loc, cl_) -> let@ cl = translate_cn_clause env cl_ in let here = Locations.other __FUNCTION__ in - return (RP.Clause.{ loc; guard = IT.bool_ true here; packing_ft = cl } :: acc) + return (Def.Clause.{ loc; guard = IT.bool_ true here; packing_ft = cl } :: acc) | CN_if (loc, e_, cl_, clauses') -> let@ e = Pure.handle "Predicate guards" (ET.translate_cn_expr Sym.Set.empty env e_) in let@ cl = translate_cn_clause env cl_ in - self (RP.{ loc; guard = IT.Surface.proj e; packing_ft = cl } :: acc) clauses' + self (Def.{ loc; guard = IT.Surface.proj e; packing_ft = cl } :: acc) clauses' in let@ xs = self [] clauses in return (List.rev xs) @@ -1394,7 +1394,6 @@ let translate_option_cn_clauses env = function let translate_cn_predicate env (def : cn_predicate) = - let open RP in Pp.debug 2 (lazy (Pp.item "translating predicate defn" (Sym.pp def.cn_pred_name))); let iargs, output_bt = match lookup_predicate def.cn_pred_name env with @@ -1409,7 +1408,7 @@ let translate_cn_predicate env (def : cn_predicate) = | (iarg0, BaseTypes.Loc ()) :: iargs' -> return ( def.cn_pred_name, - Definition. + Def.Predicate. { loc = def.cn_pred_loc; pointer = iarg0; iargs = iargs'; diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index 50c118a43..8e5d57e3f 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -274,13 +274,13 @@ let not_given_to_solver ctxt = let funs = Sym.Map.bindings (Sym.Map.filter - (fun _ v -> not (LogicalFunctions.given_to_solver v)) + (fun _ v -> not (Definition.Function.given_to_solver v)) global.logical_functions) in let preds = Sym.Map.bindings (Sym.Map.filter - (fun _ v -> not (ResourcePredicates.given_to_solver v)) + (fun _ v -> not (Definition.given_to_solver v)) global.resource_predicates) in (constraints, funs, preds) diff --git a/backend/cn/lib/definition.ml b/backend/cn/lib/definition.ml new file mode 100644 index 000000000..e8c3ea11b --- /dev/null +++ b/backend/cn/lib/definition.ml @@ -0,0 +1,223 @@ +module IT = IndexTerms +module AT = ArgumentTypes +module LAT = LogicalArgumentTypes + +module Function = struct + type def_or_uninterp = + | Def of IT.t + | Rec_Def of IT.t + | Uninterp + + let subst_def_or_uninterp subst = function + | Def it -> Def (IT.subst subst it) + | Rec_Def it -> Rec_Def (IT.subst subst it) + | Uninterp -> Uninterp + + + type definition = + { loc : Locations.t; + args : (Sym.t * BaseTypes.t) list; + (* If the predicate is supposed to get used in a quantified form, one of the arguments + has to be the index/quantified variable. For now at least. *) + return_bt : BaseTypes.t; + emit_coq : bool; + definition : def_or_uninterp + } + + let is_recursive def = + match def.definition with Rec_Def _ -> true | Def _ -> false | Uninterp -> false + + + let given_to_solver def = + match def.definition with Rec_Def _ -> false | Def _ -> true | Uninterp -> false + + + let pp_args xs = + Pp.flow_map + (Pp.break 1) + (fun (sym, typ) -> Pp.parens (Pp.typ (Sym.pp sym) (BaseTypes.pp typ))) + xs + + + let pp_def nm def = + let open Pp in + nm + ^^ colon + ^^^ pp_args def.args + ^^ colon + ^/^ + match def.definition with + | Uninterp -> !^"uninterpreted" + | Def t -> IT.pp t + | Rec_Def t -> !^"rec:" ^^^ IT.pp t + + + let open_fun def_args def_body args = + let su = IT.make_subst (List.map2 (fun (s, _) arg -> (s, arg)) def_args args) in + IT.subst su def_body + + + let unroll_once def args = + match def.definition with + | Def body | Rec_Def body -> Some (open_fun def.args body args) + | Uninterp -> None + + + let try_open_fun def args = + match def.definition with + | Def body -> Some (open_fun def.args body args) + | Rec_Def _ -> None + | Uninterp -> None + + + (* let try_open_fun_to_term def name args = Option.map (fun body -> Body.to_term + def.return_bt body ) (try_open_fun def name args) *) + + (* let add_unfolds_to_terms preds terms = let rec f acc t = match IT.term t with | + IT.Apply (name, ts) -> let def = Sym.Map.find name preds in begin match + try_open_fun_to_term def name ts with | None -> acc | Some t2 -> f (t2 :: acc) t2 end | + _ -> acc in IT.fold_list (fun _ acc t -> f acc t) [] terms terms *) + + (* (\* Check for cycles in the logical predicate graph, which would cause *) + (* the system to loop trying to unfold them. Predicates whose definition *) + (* are marked with Rec_Def aren't checked, as cycles there are expected. *\) *) + (* let cycle_check (defs : definition Sym.Map.t) = *) + (* let def_preds nm = *) + (* let def = Sym.Map.find nm defs in *) + (* begin match def.definition with *) + (* | Def t -> Sym.Set.elements (IT.preds_of (Body.to_term def.return_bt t)) *) + (* | _ -> [] *) + (* end *) + (* in *) + (* let rec search known_ok = function *) + (* | [] -> None *) + (* | (nm, Some path) :: q -> if Sym.Set.mem nm known_ok *) + (* then search known_ok q *) + (* else if List.exists (Sym.equal nm) path *) + (* then Some (List.rev path @ [nm]) *) + (* else *) + (* let deps = List.map (fun p -> (p, Some (nm :: path))) (def_preds nm) in *) + (* search known_ok (deps @ [(nm, None)] @ q) *) + (* | (nm, None) :: q -> search (Sym.Set.add nm known_ok) q *) + (* in search Sym.Set.empty (List.map (fun (p, _) -> (p, Some [])) (Sym.Map.bindings + defs)) *) + + (*Extensibility hook. For now, all functions are displayed as "interesting" in error reporting*) + let is_interesting : definition -> bool = fun _ -> true +end + +module Clause = struct + type t = + { loc : Locations.t; + guard : IT.t; + packing_ft : LAT.packing_ft + } + + let pp { loc = _; guard; packing_ft } = + let open Pp in + item "condition" (IT.pp guard) + ^^ comma + ^^^ item "return type" (LAT.pp IT.pp packing_ft) + + + let subst subst { loc; guard; packing_ft } = + { loc; + guard = IT.subst subst guard; + packing_ft = LAT.subst IT.subst subst packing_ft + } + + + let lrt (pred_oarg : IT.t) clause_packing_ft = + let module LRT = LogicalReturnTypes in + let rec aux = function + | LAT.Define (bound, info, lat) -> LRT.Define (bound, info, aux lat) + | LAT.Resource (bound, info, lat) -> LRT.Resource (bound, info, aux lat) + | LAT.Constraint (lc, info, lat) -> LRT.Constraint (lc, info, aux lat) + | I output -> + let loc = Locations.other __FUNCTION__ in + let lc = LogicalConstraints.T (IT.eq_ (pred_oarg, output) loc) in + LRT.Constraint (lc, (loc, None), LRT.I) + in + aux clause_packing_ft +end + +module Predicate = struct + type t = + { loc : Locations.t; + pointer : Sym.t; + iargs : (Sym.t * BaseTypes.t) list; + oarg_bt : BaseTypes.t; + clauses : Clause.t list option + } + + let pp def = + let open Pp in + item "pointer" (Sym.pp def.pointer) + ^/^ item "iargs" (Pp.list (fun (s, _) -> Sym.pp s) def.iargs) + ^/^ item "oarg_bt" (BaseTypes.pp def.oarg_bt) + ^/^ item + "clauses" + (match def.clauses with + | Some clauses -> Pp.list Clause.pp clauses + | None -> !^"(uninterpreted)") +end + +let alloc = + Predicate. + { loc = Locations.other (__FILE__ ^ ":" ^ string_of_int __LINE__); + pointer = Sym.fresh_named "ptr"; + iargs = []; + oarg_bt = Alloc.History.value_bt; + clauses = None + } + + +let instantiate_clauses (def : Predicate.t) ptr_arg iargs = + match def.clauses with + | Some clauses -> + let subst = + IT.make_subst + ((def.pointer, ptr_arg) + :: List.map2 (fun (def_ia, _) ia -> (def_ia, ia)) def.iargs iargs) + in + Some (List.map (Clause.subst subst) clauses) + | None -> None + + +let identify_right_clause provable (def : Predicate.t) pointer iargs = + match instantiate_clauses def pointer iargs with + | None -> + (* "uninterpreted" predicates cannot be un/packed *) + None + | Some clauses -> + let rec try_clauses : Clause.t list -> _ = function + | [] -> None + | clause :: clauses -> + (match provable (LogicalConstraints.T clause.guard) with + | `True -> Some clause + | `False -> + let loc = Locations.other __FUNCTION__ in + (match provable (LogicalConstraints.T (IT.not_ clause.guard loc)) with + | `True -> try_clauses clauses + | `False -> + Pp.debug + 5 + (lazy + (Pp.item "cannot prove or disprove clause guard" (IT.pp clause.guard))); + None)) + in + try_clauses clauses + + +(* determines if a resource predicate will be given to the solver + TODO: right now this is an overapproximation *) +let given_to_solver (def : Predicate.t) = + match def.clauses with + | None -> false + | Some [] -> true + | Some [ _ ] -> true + | _ -> false + + +(*Extensibility hook. For now, all predicates are displayed as "interesting" in error reporting*) +let is_interesting : Predicate.t -> bool = fun _ -> true diff --git a/backend/cn/lib/executable_spec_internal.ml b/backend/cn/lib/executable_spec_internal.ml index d3d889884..f6cf6d066 100644 --- a/backend/cn/lib/executable_spec_internal.ml +++ b/backend/cn/lib/executable_spec_internal.ml @@ -353,15 +353,14 @@ let bt_is_record_or_tuple = function BT.Record _ | BT.Tuple _ -> true | _ -> fal let fns_and_preds_with_record_rt (funs, preds) = let funs' = List.filter - (fun (_, (def : LogicalFunctions.definition)) -> + (fun (_, (def : Definition.Function.definition)) -> bt_is_record_or_tuple def.return_bt) funs in let fun_syms = List.map (fun (fn_sym, _) -> fn_sym) funs' in let preds' = List.filter - (fun (_, (def : ResourcePredicates.Definition.t)) -> - bt_is_record_or_tuple def.oarg_bt) + (fun (_, (def : Definition.Predicate.t)) -> bt_is_record_or_tuple def.oarg_bt) preds in let pred_syms = List.map (fun (pred_sym, _) -> pred_sym) preds' in @@ -370,7 +369,7 @@ let fns_and_preds_with_record_rt (funs, preds) = let generate_c_functions_internal (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) - (logical_predicates : (Sym.t * LogicalFunctions.definition) list) + (logical_predicates : (Sym.t * Definition.Function.definition) list) = let ail_funs_and_records = List.map @@ -440,7 +439,7 @@ let rec remove_duplicates eq_fun = function let generate_c_predicates_internal (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) - (resource_predicates : (Sym.t * ResourcePredicates.Definition.t) list) + (resource_predicates : (Sym.t * Definition.Predicate.t) list) = (* let ail_info = List.map (fun cn_f -> Cn_internal_to_ail.cn_to_ail_predicate_internal cn_f sigm.cn_datatypes [] ownership_ctypes resource_predicates) resource_predicates diff --git a/backend/cn/lib/executable_spec_records.ml b/backend/cn/lib/executable_spec_records.ml index 13022fe47..f16abd0fe 100644 --- a/backend/cn/lib/executable_spec_records.ml +++ b/backend/cn/lib/executable_spec_records.ml @@ -141,13 +141,11 @@ let rec populate ?cn_sym bt = let add_records_to_map_from_fns_and_preds cn_funs cn_preds = let fun_syms_and_ret_types = List.map - (fun (sym, (def : LogicalFunctions.definition)) -> (sym, def.return_bt)) + (fun (sym, (def : Definition.Function.definition)) -> (sym, def.return_bt)) cn_funs in let pred_syms_and_ret_types = - List.map - (fun (sym, (def : ResourcePredicates.Definition.t)) -> (sym, def.oarg_bt)) - cn_preds + List.map (fun (sym, (def : Definition.Predicate.t)) -> (sym, def.oarg_bt)) cn_preds in List.iter (fun (cn_sym, bt) -> populate ~cn_sym bt) diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index e0b8df710..d9354a371 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -2,10 +2,10 @@ open Report module IT = IndexTerms module BT = BaseTypes module Res = Resource -module REP = ResourcePredicates +module Def = Definition module Req = Request module LC = LogicalConstraints -module LF = LogicalFunctions +module LF = Definition.Function module LAT = LogicalArgumentTypes module StringMap = Map.Make (String) module C = Context @@ -39,7 +39,7 @@ let clause_has_resource req c = | Define (_, _, c) -> f c | I _ -> false in - f c.REP.Clause.packing_ft + f c.Def.Clause.packing_ft let relevant_predicate_clauses global name req = @@ -47,7 +47,7 @@ let relevant_predicate_clauses global name req = let clauses = let defs = Sym.Map.bindings global.resource_predicates in List.concat_map - (fun (nm, (def : REP.Definition.t)) -> + (fun (nm, (def : Def.Predicate.t)) -> match def.clauses with | Some clauses -> List.map (fun c -> (nm, c)) clauses | None -> []) @@ -205,7 +205,7 @@ let state ctxt log model_with_q extras = List.partition (fun (_, v) -> LF.is_interesting v) funs in let interesting_preds, uninteresting_preds = - List.partition (fun (_, v) -> REP.is_interesting v) preds + List.partition (fun (_, v) -> Def.is_interesting v) preds in add_labeled lab_interesting @@ -353,12 +353,12 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra match extras.request with | None -> [] | Some req -> - let open ResourcePredicates in + let open Definition in (match Req.get_name req with | Owned _ -> [] | PName pname -> let doc_clause (_name, c) = - { cond = IT.pp c.REP.Clause.guard; + { cond = IT.pp c.Def.Clause.guard; clause = LogicalArgumentTypes.pp IT.pp (simp_resource evaluate c.packing_ft) } in diff --git a/backend/cn/lib/global.ml b/backend/cn/lib/global.ml index 04c624646..630d5a472 100644 --- a/backend/cn/lib/global.ml +++ b/backend/cn/lib/global.ml @@ -9,8 +9,8 @@ type t = datatype_constrs : BaseTypes.constr_info Sym.Map.t; datatype_order : Sym.t list list option; fun_decls : (Locations.t * AT.ft option * Sctypes.c_concrete_sig) Sym.Map.t; - resource_predicates : ResourcePredicates.Definition.t Sym.Map.t; - logical_functions : LogicalFunctions.definition Sym.Map.t; + resource_predicates : Definition.Predicate.t Sym.Map.t; + logical_functions : Definition.Function.definition Sym.Map.t; lemmata : (Locations.t * AT.lemmat) Sym.Map.t } @@ -20,8 +20,7 @@ let empty = datatype_constrs = Sym.Map.empty; datatype_order = None; fun_decls = Sym.Map.empty; - resource_predicates = - Sym.Map.(empty |> add Alloc.Predicate.sym ResourcePredicates.alloc); + resource_predicates = Sym.Map.(empty |> add Alloc.Predicate.sym Definition.alloc); logical_functions = Sym.Map.empty; lemmata = Sym.Map.empty } @@ -68,7 +67,7 @@ let pp_fun_decls decls = flow_map hardline pp_fun_decl (Sym.Map.bindings decls) let pp_resource_predicate_definitions defs = separate_map hardline - (fun (name, def) -> item (Sym.pp_string name) (ResourcePredicates.Definition.pp def)) + (fun (name, def) -> item (Sym.pp_string name) (Definition.Predicate.pp def)) (Sym.Map.bindings defs) diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index baac426cb..dc44cebc5 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -6,7 +6,7 @@ module AT = ArgumentTypes module LAT = LogicalArgumentTypes module TE = TypeErrors module Loc = Locations -module LF = LogicalFunctions +module LF = Definition.Function module LC = LogicalConstraints module IdSet = Set.Make (Id) module StringSet = Set.Make (String) @@ -405,7 +405,7 @@ let it_adjust (global : Global.t) it = else IT.eachI_ (i1, (s, bt), i2) x loc | IT.Apply (name, args) -> - let open LogicalFunctions in + let open Definition.Function in let def = Sym.Map.find name global.logical_functions in (match (def.definition, def.emit_coq) with | Def body, false -> f (open_fun def.args body args) @@ -442,7 +442,7 @@ let fun_prop_ret (global : Global.t) nm = match Sym.Map.find_opt nm global.logical_functions with | None -> fail "fun_prop_ret: not found" (Sym.pp nm) | Some def -> - let open LogicalFunctions in + let open Definition.Function in BaseTypes.equal BaseTypes.Bool def.return_bt && StringSet.mem (Sym.pp_string nm) prop_funs @@ -778,7 +778,7 @@ let ensure_tuple_op is_upd nm (ix, l) = let ensure_pred global list_mono loc name aux = - let open LogicalFunctions in + let open Definition.Function in let def = Sym.Map.find name global.Global.logical_functions in let inf = (loc, Pp.typ (Pp.string "pred") (Sym.pp name)) in match def.definition with @@ -848,7 +848,7 @@ let ensure_struct_mem is_good global list_mono loc ct aux = let rec unfold_if_possible global it = let open IT in - let open LogicalFunctions in + let open Definition.Function in match it with | IT (IT.Apply (name, args), _, _) -> let def = Option.get (Global.get_logical_function_def global name) in diff --git a/backend/cn/lib/logicalFunctions.ml b/backend/cn/lib/logicalFunctions.ml deleted file mode 100644 index a5d391047..000000000 --- a/backend/cn/lib/logicalFunctions.ml +++ /dev/null @@ -1,107 +0,0 @@ -module Loc = Locations -module IT = IndexTerms -module AT = ArgumentTypes -module LAT = LogicalArgumentTypes -open IndexTerms - -type def_or_uninterp = - | Def of IT.t - | Rec_Def of IT.t - | Uninterp - -let subst_def_or_uninterp subst = function - | Def it -> Def (IT.subst subst it) - | Rec_Def it -> Rec_Def (IT.subst subst it) - | Uninterp -> Uninterp - - -type definition = - { loc : Locations.t; - args : (Sym.t * BaseTypes.t) list; - (* If the predicate is supposed to get used in a quantified form, one of the arguments - has to be the index/quantified variable. For now at least. *) - return_bt : BaseTypes.t; - emit_coq : bool; - definition : def_or_uninterp - } - -let is_recursive def = - match def.definition with Rec_Def _ -> true | Def _ -> false | Uninterp -> false - - -let given_to_solver def = - match def.definition with Rec_Def _ -> false | Def _ -> true | Uninterp -> false - - -let pp_args xs = - Pp.flow_map - (Pp.break 1) - (fun (sym, typ) -> Pp.parens (Pp.typ (Sym.pp sym) (BaseTypes.pp typ))) - xs - - -let pp_def nm def = - let open Pp in - nm - ^^ colon - ^^^ pp_args def.args - ^^ colon - ^/^ - match def.definition with - | Uninterp -> !^"uninterpreted" - | Def t -> IT.pp t - | Rec_Def t -> !^"rec:" ^^^ IT.pp t - - -let open_fun def_args def_body args = - let su = make_subst (List.map2 (fun (s, _) arg -> (s, arg)) def_args args) in - IT.subst su def_body - - -let unroll_once def args = - match def.definition with - | Def body | Rec_Def body -> Some (open_fun def.args body args) - | Uninterp -> None - - -let try_open_fun def args = - match def.definition with - | Def body -> Some (open_fun def.args body args) - | Rec_Def _ -> None - | Uninterp -> None - - -(* let try_open_fun_to_term def name args = Option.map (fun body -> Body.to_term - def.return_bt body ) (try_open_fun def name args) *) - -(* let add_unfolds_to_terms preds terms = let rec f acc t = match IT.term t with | - IT.Apply (name, ts) -> let def = Sym.Map.find name preds in begin match - try_open_fun_to_term def name ts with | None -> acc | Some t2 -> f (t2 :: acc) t2 end | - _ -> acc in IT.fold_list (fun _ acc t -> f acc t) [] terms terms *) - -(* (\* Check for cycles in the logical predicate graph, which would cause *) -(* the system to loop trying to unfold them. Predicates whose definition *) -(* are marked with Rec_Def aren't checked, as cycles there are expected. *\) *) -(* let cycle_check (defs : definition Sym.Map.t) = *) -(* let def_preds nm = *) -(* let def = Sym.Map.find nm defs in *) -(* begin match def.definition with *) -(* | Def t -> Sym.Set.elements (IT.preds_of (Body.to_term def.return_bt t)) *) -(* | _ -> [] *) -(* end *) -(* in *) -(* let rec search known_ok = function *) -(* | [] -> None *) -(* | (nm, Some path) :: q -> if Sym.Set.mem nm known_ok *) -(* then search known_ok q *) -(* else if List.exists (Sym.equal nm) path *) -(* then Some (List.rev path @ [nm]) *) -(* else *) -(* let deps = List.map (fun p -> (p, Some (nm :: path))) (def_preds nm) in *) -(* search known_ok (deps @ [(nm, None)] @ q) *) -(* | (nm, None) :: q -> search (Sym.Set.add nm known_ok) q *) -(* in search Sym.Set.empty (List.map (fun (p, _) -> (p, Some [])) (Sym.Map.bindings - defs)) *) - -(*Extensibility hook. For now, all functions are displayed as "interesting" in error reporting*) -let is_interesting : definition -> bool = fun _ -> true diff --git a/backend/cn/lib/mucore.ml b/backend/cn/lib/mucore.ml index 2ab7227b9..538e636b1 100644 --- a/backend/cn/lib/mucore.ml +++ b/backend/cn/lib/mucore.ml @@ -428,8 +428,8 @@ type 'TY file = extern : Cerb_frontend.Core.extern_map; stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; - resource_predicates : (Sym.t * ResourcePredicates.Definition.t) list; - logical_predicates : (Sym.t * LogicalFunctions.definition) list; + resource_predicates : (Sym.t * Definition.Predicate.t) list; + logical_predicates : (Sym.t * Definition.Function.definition) list; datatypes : (Sym.t * datatype) list; lemmata : (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list; call_funinfo : (Sym.t, Sctypes.c_concrete_sig) Pmap.map diff --git a/backend/cn/lib/mucore.mli b/backend/cn/lib/mucore.mli index d3b657d68..fac5c3c23 100644 --- a/backend/cn/lib/mucore.mli +++ b/backend/cn/lib/mucore.mli @@ -331,8 +331,8 @@ type 'TY file = extern : Cerb_frontend.Core.extern_map; stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; - resource_predicates : (Sym.t * ResourcePredicates.Definition.t) list; - logical_predicates : (Sym.t * LogicalFunctions.definition) list; + resource_predicates : (Sym.t * Definition.Predicate.t) list; + logical_predicates : (Sym.t * Definition.Function.definition) list; datatypes : (Sym.t * datatype) list; lemmata : (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list; call_funinfo : (Sym.t, Sctypes.c_concrete_sig) Pmap.map diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index 02266cb98..fee01a4df 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -1,6 +1,6 @@ open Request open Resource -open ResourcePredicates +open Definition open Memory module IT = IndexTerms module LAT = LogicalArgumentTypes @@ -143,7 +143,7 @@ let unpack loc global provable (ret, O o) = | _ -> (match packing_ft loc global provable ret with | None -> None - | Some packing_ft -> Some (`LRT (ResourcePredicates.Clause.lrt o packing_ft))) + | Some packing_ft -> Some (`LRT (Definition.Clause.lrt o packing_ft))) let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O o) = diff --git a/backend/cn/lib/resourcePredicates.ml b/backend/cn/lib/resourcePredicates.ml deleted file mode 100644 index 6e6fa48eb..000000000 --- a/backend/cn/lib/resourcePredicates.ml +++ /dev/null @@ -1,118 +0,0 @@ -module IT = IndexTerms -module LAT = LogicalArgumentTypes - -module Clause = struct - type t = - { loc : Locations.t; - guard : IT.t; - packing_ft : LAT.packing_ft - } - - let pp { loc = _; guard; packing_ft } = - let open Pp in - item "condition" (IT.pp guard) - ^^ comma - ^^^ item "return type" (LAT.pp IT.pp packing_ft) - - - let subst subst { loc; guard; packing_ft } = - { loc; - guard = IT.subst subst guard; - packing_ft = LAT.subst IT.subst subst packing_ft - } - - - let lrt (pred_oarg : IT.t) clause_packing_ft = - let module LRT = LogicalReturnTypes in - let rec aux = function - | LAT.Define (bound, info, lat) -> LRT.Define (bound, info, aux lat) - | LAT.Resource (bound, info, lat) -> LRT.Resource (bound, info, aux lat) - | LAT.Constraint (lc, info, lat) -> LRT.Constraint (lc, info, aux lat) - | I output -> - let loc = Locations.other __FUNCTION__ in - let lc = LogicalConstraints.T (IT.eq_ (pred_oarg, output) loc) in - LRT.Constraint (lc, (loc, None), LRT.I) - in - aux clause_packing_ft -end - -module Definition = struct - type t = - { loc : Locations.t; - pointer : Sym.t; - iargs : (Sym.t * BaseTypes.t) list; - oarg_bt : BaseTypes.t; - clauses : Clause.t list option - } - - let pp def = - let open Pp in - item "pointer" (Sym.pp def.pointer) - ^/^ item "iargs" (Pp.list (fun (s, _) -> Sym.pp s) def.iargs) - ^/^ item "oarg_bt" (BaseTypes.pp def.oarg_bt) - ^/^ item - "clauses" - (match def.clauses with - | Some clauses -> Pp.list Clause.pp clauses - | None -> !^"(uninterpreted)") -end - -let alloc = - Definition. - { loc = Locations.other (__FILE__ ^ ":" ^ string_of_int __LINE__); - pointer = Sym.fresh_named "ptr"; - iargs = []; - oarg_bt = Alloc.History.value_bt; - clauses = None - } - - -let instantiate_clauses (def : Definition.t) ptr_arg iargs = - match def.clauses with - | Some clauses -> - let subst = - IT.make_subst - ((def.pointer, ptr_arg) - :: List.map2 (fun (def_ia, _) ia -> (def_ia, ia)) def.iargs iargs) - in - Some (List.map (Clause.subst subst) clauses) - | None -> None - - -let identify_right_clause provable (def : Definition.t) pointer iargs = - match instantiate_clauses def pointer iargs with - | None -> - (* "uninterpreted" predicates cannot be un/packed *) - None - | Some clauses -> - let rec try_clauses : Clause.t list -> _ = function - | [] -> None - | clause :: clauses -> - (match provable (LogicalConstraints.T clause.guard) with - | `True -> Some clause - | `False -> - let loc = Locations.other __FUNCTION__ in - (match provable (LogicalConstraints.T (IT.not_ clause.guard loc)) with - | `True -> try_clauses clauses - | `False -> - Pp.debug - 5 - (lazy - (Pp.item "cannot prove or disprove clause guard" (IT.pp clause.guard))); - None)) - in - try_clauses clauses - - -(* determines if a resource predicate will be given to the solver - TODO: right now this is an overapproximation *) -let given_to_solver (def : Definition.t) = - match def.clauses with - | None -> false - | Some [] -> true - | Some [ _ ] -> true - | _ -> false - - -(*Extensibility hook. For now, all predicates are displayed as "interesting" in error reporting*) -let is_interesting : Definition.t -> bool = fun _ -> true diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index 013c17692..a81d0c287 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -597,7 +597,7 @@ module IndexTerms = struct t else ( let def = Sym.Map.find name simp_ctxt.global.logical_functions in - match LogicalFunctions.try_open_fun def args with + match Definition.Function.try_open_fun def args with | Some inlined -> aux inlined | None -> t) | _ -> diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 1e3532709..79556766d 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -1003,7 +1003,7 @@ let rec translate_term s iterm = | Apply (name, args) -> let def = Option.get (get_logical_function_def s.globals name) in (match def.definition with - | Def body -> translate_term s (LogicalFunctions.open_fun def.args body args) + | Def body -> translate_term s (Definition.Function.open_fun def.args body args) | _ -> let do_arg arg = translate_base_type (IT.basetype arg) in let args_ts = List.map do_arg args in diff --git a/backend/cn/lib/testGeneration/genAnalysis.ml b/backend/cn/lib/testGeneration/genAnalysis.ml index 3be7175ea..0de201d70 100644 --- a/backend/cn/lib/testGeneration/genAnalysis.ml +++ b/backend/cn/lib/testGeneration/genAnalysis.ml @@ -3,7 +3,7 @@ module BT = BaseTypes module IT = IndexTerms module Req = Request module LC = LogicalConstraints -module RP = ResourcePredicates +module Def = Definition module LAT = LogicalArgumentTypes module GT = GenTerms module GD = GenDefinitions @@ -150,11 +150,11 @@ end let get_bounds = Bounds.get_bounds -let get_recursive_preds (preds : (Sym.t * RP.Definition.t) list) : Sym.Set.t = - let get_calls (pred : RP.Definition.t) : Sym.Set.t = +let get_recursive_preds (preds : (Sym.t * Def.Predicate.t) list) : Sym.Set.t = + let get_calls (pred : Def.Predicate.t) : Sym.Set.t = pred.clauses |> Option.get - |> List.map (fun (cl : RP.Clause.t) -> cl.packing_ft) + |> List.map (fun (cl : Def.Clause.t) -> cl.packing_ft) |> List.map LAT.r_resource_requests |> List.flatten |> List.map snd diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index 1a4432380..f372fb22a 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -3,7 +3,7 @@ module BT = BaseTypes module AT = ArgumentTypes module LC = LogicalConstraints module LAT = LogicalArgumentTypes -module RP = ResourcePredicates +module Def = Definition module Req = Request module GBT = GenBaseTypes module GT = GenTerms @@ -33,7 +33,7 @@ let compile_oargs (ret_bt : BT.t) (iargs : (Sym.t * BT.t) list) : (Sym.t * BT.t) let add_request (recursive : Sym.Set.t) - (preds : (Sym.Map.key * RP.Definition.t) list) + (preds : (Sym.Map.key * Def.Predicate.t) list) (fsym : Sym.t) : unit m = @@ -99,7 +99,7 @@ let compile_vars (generated : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) (lat : I let rec compile_it_lat (filename : string) (recursive : Sym.Set.t) - (preds : (Sym.t * RP.Definition.t) list) + (preds : (Sym.t * Def.Predicate.t) list) (name : Sym.t) (generated : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) @@ -270,11 +270,11 @@ let rec compile_it_lat let rec compile_clauses (filename : string) (recursive : Sym.Set.t) - (preds : (Sym.t * RP.Definition.t) list) + (preds : (Sym.t * Def.Predicate.t) list) (name : Sym.t) (iargs : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) - (cls : RP.Clause.t list) + (cls : Def.Clause.t list) : GT.t m = match cls with @@ -293,7 +293,7 @@ let rec compile_clauses let compile_pred (recursive_preds : Sym.Set.t) - (preds : (Sym.t * RP.Definition.t) list) + (preds : (Sym.t * Def.Predicate.t) list) ({ filename; recursive; spec; name; iargs; oargs; body } : GD.t) : unit m = @@ -316,7 +316,7 @@ let compile_pred let compile_spec (filename : string) (recursive : Sym.Set.t) - (preds : (Sym.t * RP.Definition.t) list) + (preds : (Sym.t * Def.Predicate.t) list) (name : Sym.t) (at : 'a AT.t) : unit m @@ -374,7 +374,7 @@ let compile_spec let compile ?(ctx : GD.context option) - (preds : (Sym.t * RP.Definition.t) list) + (preds : (Sym.t * Def.Predicate.t) list) (insts : Executable_spec_extract.instrumentation list) : GD.context = diff --git a/backend/cn/lib/testGeneration/genCompile.mli b/backend/cn/lib/testGeneration/genCompile.mli index a48289926..0c38fcc34 100644 --- a/backend/cn/lib/testGeneration/genCompile.mli +++ b/backend/cn/lib/testGeneration/genCompile.mli @@ -1,5 +1,5 @@ val compile : ?ctx:GenDefinitions.context -> - (Sym.t * ResourcePredicates.Definition.t) list -> + (Sym.t * Definition.Predicate.t) list -> Executable_spec_extract.instrumentation list -> GenDefinitions.context diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 394222b38..63d628ed4 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -116,9 +116,9 @@ val get_fun_decl val get_lemma : Locations.t -> Sym.t -> (Locations.t * Global.AT.lemmat) m -val get_resource_predicate_def : Locations.t -> Sym.t -> ResourcePredicates.Definition.t m +val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t m -val get_logical_function_def : Locations.t -> Sym.t -> LogicalFunctions.definition m +val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.definition m val add_struct_decl : Sym.t -> Memory.struct_layout -> unit m @@ -129,9 +129,9 @@ val add_fun_decl val add_lemma : Sym.t -> Locations.t * ArgumentTypes.lemmat -> unit m -val add_resource_predicate : Sym.t -> ResourcePredicates.Definition.t -> unit m +val add_resource_predicate : Sym.t -> Definition.Predicate.t -> unit m -val add_logical_function : Sym.t -> LogicalFunctions.definition -> unit m +val add_logical_function : Sym.t -> Definition.Function.definition -> unit m val add_datatype : Sym.t -> BaseTypes.dt_info -> unit m diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index d2491937f..e49d08a1c 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -3,6 +3,7 @@ module BT = BaseTypes module TE = TypeErrors module Res = Resource module Req = Request +module Def = Definition module LRT = LogicalReturnTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes @@ -1862,7 +1863,7 @@ module BaseTyping = struct return (Extract (attrs, to_extract, it)) | Unfold (f, its) -> let@ def = get_logical_function_def loc f in - if LogicalFunctions.is_recursive def then + if Definition.Function.is_recursive def then () else Pp.warn loc (Pp.item "unfold of function not marked [rec] (no effect)" (Sym.pp f)); @@ -2250,9 +2251,7 @@ module WProc = struct end module WRPD = struct - open ResourcePredicates - - let welltyped Definition.{ loc; pointer; iargs; oarg_bt; clauses } = + let welltyped Def.Predicate.{ loc; pointer; iargs; oarg_bt; clauses } = (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure (let@ () = add_l pointer BT.(Loc ()) (loc, lazy (Pp.string "ptr-var")) in @@ -2271,11 +2270,11 @@ module WRPD = struct | Some clauses -> let@ clauses = ListM.fold_leftM - (fun acc Clause.{ loc; guard; packing_ft } -> + (fun acc Def.Clause.{ loc; guard; packing_ft } -> let@ guard = WIT.check loc BT.Bool guard in let here = Locations.other __FUNCTION__ in let negated_guards = - List.map (fun clause -> IT.not_ clause.Clause.guard here) acc + List.map (fun clause -> IT.not_ clause.Def.Clause.guard here) acc in pure (let@ () = add_c loc (LC.T guard) in @@ -2288,20 +2287,20 @@ module WRPD = struct loc packing_ft in - return (acc @ [ Clause.{ loc; guard; packing_ft } ]))) + return (acc @ [ Def.Clause.{ loc; guard; packing_ft } ]))) [] clauses in return (Some clauses) in - return Definition.{ loc; pointer; iargs; oarg_bt; clauses }) + return Def.Predicate.{ loc; pointer; iargs; oarg_bt; clauses }) end module WLFD = struct - open LogicalFunctions + open Definition.Function let welltyped - ({ loc; args; return_bt; emit_coq; definition } : LogicalFunctions.definition) + ({ loc; args; return_bt; emit_coq; definition } : Definition.Function.definition) = (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure From 0749b8eab388344442a918e8156d71727a4979c5 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 19:02:29 +0000 Subject: [PATCH 100/148] Tidy up Definition module --- backend/cn/lib/cLogicalFuns.ml | 4 +- backend/cn/lib/check.ml | 2 +- backend/cn/lib/cn_internal_to_ail.ml | 4 +- backend/cn/lib/cn_internal_to_ail.mli | 2 +- backend/cn/lib/compile.ml | 6 +- backend/cn/lib/context.ml | 2 +- backend/cn/lib/definition.ml | 156 ++++++++----------- backend/cn/lib/definition.mli | 73 +++++++++ backend/cn/lib/executable_spec_internal.ml | 5 +- backend/cn/lib/executable_spec_records.ml | 4 +- backend/cn/lib/explain.ml | 1 - backend/cn/lib/global.ml | 2 +- backend/cn/lib/lemmata.ml | 10 +- backend/cn/lib/mucore.ml | 2 +- backend/cn/lib/mucore.mli | 2 +- backend/cn/lib/pack.ml | 2 +- backend/cn/lib/simplify.ml | 2 +- backend/cn/lib/solver.ml | 4 +- backend/cn/lib/testGeneration/genOptimize.ml | 12 +- backend/cn/lib/typing.mli | 4 +- backend/cn/lib/wellTyped.ml | 10 +- 21 files changed, 172 insertions(+), 137 deletions(-) create mode 100644 backend/cn/lib/definition.mli diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index b805031f6..fde6f7448 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -714,8 +714,8 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ let upd_def (loc, sym, def_tm) = let open Definition.Function in let@ def = get_logical_function_def loc sym in - match def.definition with - | Uninterp -> add_logical_function sym { def with definition = Def def_tm } + match def.body with + | Uninterp -> add_logical_function sym { def with body = Def def_tm } | _ -> fail_n { loc; diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index b9fd514d1..3f0d54d36 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -2230,7 +2230,7 @@ let record_and_check_logical_functions funs = let@ () = ListM.iterM (fun (name, def) -> - let@ simple_def = WellTyped.WLFD.welltyped { def with definition = Uninterp } in + let@ simple_def = WellTyped.WLFD.welltyped { def with body = Uninterp } in add_logical_function name simple_def) recursive in diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index ac88aa73f..203f5a0d8 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -2932,7 +2932,7 @@ let rec generate_record_opt pred_sym = function (* TODO: Finish with rest of function - maybe header file with A.Decl_function (cn.h?) *) let cn_to_ail_function_internal - (fn_sym, (lf_def : Definition.Function.definition)) + (fn_sym, (lf_def : Definition.Function.t)) (cn_datatypes : A.sigma_cn_datatype list) (cn_functions : A.sigma_cn_function list) : ((Locations.t * A.sigma_declaration) @@ -2942,7 +2942,7 @@ let cn_to_ail_function_internal let ret_type = bt_to_ail_ctype ~pred_sym:(Some fn_sym) lf_def.return_bt in (* let ret_type = mk_ctype C.(Pointer (empty_qualifiers, ret_type)) in *) let bs, ail_func_body_opt = - match lf_def.definition with + match lf_def.body with | Def it | Rec_Def it -> let bs, ss = cn_to_ail_expr_internal_with_pred_name (Some fn_sym) cn_datatypes [] it Return diff --git a/backend/cn/lib/cn_internal_to_ail.mli b/backend/cn/lib/cn_internal_to_ail.mli index 0840c8515..0eab96128 100644 --- a/backend/cn/lib/cn_internal_to_ail.mli +++ b/backend/cn/lib/cn_internal_to_ail.mli @@ -148,7 +148,7 @@ val cn_to_ail_records A.sigma_tag_definition list val cn_to_ail_function_internal - : Sym.t * Definition.Function.definition -> + : Sym.t * Definition.Function.t -> A.sigma_cn_datatype list -> A.sigma_cn_function list -> ((Locations.t * A.sigma_declaration) diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 4424446d8..94c498f0c 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -1218,7 +1218,7 @@ let translate_cn_function env (def : cn_function) = }) def.cn_func_attrs in - let@ definition = + let@ body = match def.cn_func_body with | Some body -> let@ body = translate_cn_func_body env' body in @@ -1232,7 +1232,7 @@ let translate_cn_function env (def : cn_function) = args = List.map_snd SBT.proj args; return_bt = SBT.proj return_bt; emit_coq = not coq_unfold; - definition + body } in return (def.cn_func_name, def2) @@ -1380,7 +1380,7 @@ let translate_cn_clauses env clauses = Pure.handle "Predicate guards" (ET.translate_cn_expr Sym.Set.empty env e_) in let@ cl = translate_cn_clause env cl_ in - self (Def.{ loc; guard = IT.Surface.proj e; packing_ft = cl } :: acc) clauses' + self ({ loc; guard = IT.Surface.proj e; packing_ft = cl } :: acc) clauses' in let@ xs = self [] clauses in return (List.rev xs) diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index 8e5d57e3f..5f6256f4c 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -280,7 +280,7 @@ let not_given_to_solver ctxt = let preds = Sym.Map.bindings (Sym.Map.filter - (fun _ v -> not (Definition.given_to_solver v)) + (fun _ v -> not (Definition.Predicate.given_to_solver v)) global.resource_predicates) in (constraints, funs, preds) diff --git a/backend/cn/lib/definition.ml b/backend/cn/lib/definition.ml index e8c3ea11b..728947d3f 100644 --- a/backend/cn/lib/definition.ml +++ b/backend/cn/lib/definition.ml @@ -3,33 +3,33 @@ module AT = ArgumentTypes module LAT = LogicalArgumentTypes module Function = struct - type def_or_uninterp = + type body = | Def of IT.t | Rec_Def of IT.t | Uninterp - let subst_def_or_uninterp subst = function + let subst_body subst = function | Def it -> Def (IT.subst subst it) | Rec_Def it -> Rec_Def (IT.subst subst it) | Uninterp -> Uninterp - type definition = + type t = { loc : Locations.t; args : (Sym.t * BaseTypes.t) list; (* If the predicate is supposed to get used in a quantified form, one of the arguments has to be the index/quantified variable. For now at least. *) return_bt : BaseTypes.t; emit_coq : bool; - definition : def_or_uninterp + body : body } let is_recursive def = - match def.definition with Rec_Def _ -> true | Def _ -> false | Uninterp -> false + match def.body with Rec_Def _ -> true | Def _ -> false | Uninterp -> false let given_to_solver def = - match def.definition with Rec_Def _ -> false | Def _ -> true | Uninterp -> false + match def.body with Rec_Def _ -> false | Def _ -> true | Uninterp -> false let pp_args xs = @@ -39,71 +39,39 @@ module Function = struct xs - let pp_def nm def = + let pp nm def = let open Pp in nm ^^ colon ^^^ pp_args def.args ^^ colon ^/^ - match def.definition with + match def.body with | Uninterp -> !^"uninterpreted" | Def t -> IT.pp t | Rec_Def t -> !^"rec:" ^^^ IT.pp t - let open_fun def_args def_body args = + let open_ def_args def_body args = let su = IT.make_subst (List.map2 (fun (s, _) arg -> (s, arg)) def_args args) in IT.subst su def_body let unroll_once def args = - match def.definition with - | Def body | Rec_Def body -> Some (open_fun def.args body args) + match def.body with + | Def body | Rec_Def body -> Some (open_ def.args body args) | Uninterp -> None - let try_open_fun def args = - match def.definition with - | Def body -> Some (open_fun def.args body args) + let try_open def args = + match def.body with + | Def body -> Some (open_ def.args body args) | Rec_Def _ -> None | Uninterp -> None - (* let try_open_fun_to_term def name args = Option.map (fun body -> Body.to_term - def.return_bt body ) (try_open_fun def name args) *) - - (* let add_unfolds_to_terms preds terms = let rec f acc t = match IT.term t with | - IT.Apply (name, ts) -> let def = Sym.Map.find name preds in begin match - try_open_fun_to_term def name ts with | None -> acc | Some t2 -> f (t2 :: acc) t2 end | - _ -> acc in IT.fold_list (fun _ acc t -> f acc t) [] terms terms *) - - (* (\* Check for cycles in the logical predicate graph, which would cause *) - (* the system to loop trying to unfold them. Predicates whose definition *) - (* are marked with Rec_Def aren't checked, as cycles there are expected. *\) *) - (* let cycle_check (defs : definition Sym.Map.t) = *) - (* let def_preds nm = *) - (* let def = Sym.Map.find nm defs in *) - (* begin match def.definition with *) - (* | Def t -> Sym.Set.elements (IT.preds_of (Body.to_term def.return_bt t)) *) - (* | _ -> [] *) - (* end *) - (* in *) - (* let rec search known_ok = function *) - (* | [] -> None *) - (* | (nm, Some path) :: q -> if Sym.Set.mem nm known_ok *) - (* then search known_ok q *) - (* else if List.exists (Sym.equal nm) path *) - (* then Some (List.rev path @ [nm]) *) - (* else *) - (* let deps = List.map (fun p -> (p, Some (nm :: path))) (def_preds nm) in *) - (* search known_ok (deps @ [(nm, None)] @ q) *) - (* | (nm, None) :: q -> search (Sym.Set.add nm known_ok) q *) - (* in search Sym.Set.empty (List.map (fun (p, _) -> (p, Some [])) (Sym.Map.bindings - defs)) *) - (*Extensibility hook. For now, all functions are displayed as "interesting" in error reporting*) - let is_interesting : definition -> bool = fun _ -> true + let is_interesting : t -> bool = fun _ -> true end module Clause = struct @@ -160,6 +128,53 @@ module Predicate = struct (match def.clauses with | Some clauses -> Pp.list Clause.pp clauses | None -> !^"(uninterpreted)") + + + let instantiate (def : t) ptr_arg iargs = + match def.clauses with + | Some clauses -> + let subst = + IT.make_subst + ((def.pointer, ptr_arg) + :: List.map2 (fun (def_ia, _) ia -> (def_ia, ia)) def.iargs iargs) + in + Some (List.map (Clause.subst subst) clauses) + | None -> None + + + let identify_right_clause provable (def : t) pointer iargs = + match instantiate def pointer iargs with + | None -> + (* "uninterpreted" predicates cannot be un/packed *) + None + | Some clauses -> + let rec try_clauses : Clause.t list -> _ = function + | [] -> None + | clause :: clauses -> + (match provable (LogicalConstraints.T clause.guard) with + | `True -> Some clause + | `False -> + let loc = Locations.other __FUNCTION__ in + (match provable (LogicalConstraints.T (IT.not_ clause.guard loc)) with + | `True -> try_clauses clauses + | `False -> + Pp.debug + 5 + (lazy + (Pp.item "cannot prove or disprove clause guard" (IT.pp clause.guard))); + None)) + in + try_clauses clauses + + + (* determines if a resource predicate will be given to the solver + * TODO: right now this is an overapproximation *) + let given_to_solver (def : t) = + match def.clauses with + | None -> false + | Some [] -> true + | Some [ _ ] -> true + | _ -> false end let alloc = @@ -172,52 +187,5 @@ let alloc = } -let instantiate_clauses (def : Predicate.t) ptr_arg iargs = - match def.clauses with - | Some clauses -> - let subst = - IT.make_subst - ((def.pointer, ptr_arg) - :: List.map2 (fun (def_ia, _) ia -> (def_ia, ia)) def.iargs iargs) - in - Some (List.map (Clause.subst subst) clauses) - | None -> None - - -let identify_right_clause provable (def : Predicate.t) pointer iargs = - match instantiate_clauses def pointer iargs with - | None -> - (* "uninterpreted" predicates cannot be un/packed *) - None - | Some clauses -> - let rec try_clauses : Clause.t list -> _ = function - | [] -> None - | clause :: clauses -> - (match provable (LogicalConstraints.T clause.guard) with - | `True -> Some clause - | `False -> - let loc = Locations.other __FUNCTION__ in - (match provable (LogicalConstraints.T (IT.not_ clause.guard loc)) with - | `True -> try_clauses clauses - | `False -> - Pp.debug - 5 - (lazy - (Pp.item "cannot prove or disprove clause guard" (IT.pp clause.guard))); - None)) - in - try_clauses clauses - - -(* determines if a resource predicate will be given to the solver - TODO: right now this is an overapproximation *) -let given_to_solver (def : Predicate.t) = - match def.clauses with - | None -> false - | Some [] -> true - | Some [ _ ] -> true - | _ -> false - - (*Extensibility hook. For now, all predicates are displayed as "interesting" in error reporting*) let is_interesting : Predicate.t -> bool = fun _ -> true diff --git a/backend/cn/lib/definition.mli b/backend/cn/lib/definition.mli new file mode 100644 index 000000000..5feaa9c77 --- /dev/null +++ b/backend/cn/lib/definition.mli @@ -0,0 +1,73 @@ +module Function : sig + type body = + | Def of IndexTerms.t + | Rec_Def of IndexTerms.t + | Uninterp + + val subst_body : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> body -> body + + type t = + { loc : Locations.t; + args : (Sym.t * BaseTypes.t) list; + return_bt : BaseTypes.t; + emit_coq : bool; + body : body + } + + val is_recursive : t -> bool + + val given_to_solver : t -> bool + + val pp_args : (Cerb_frontend.Symbol.sym * unit BaseTypes.t_gen) list -> Pp.document + + val pp : Pp.document -> t -> Pp.document + + val open_ : (Sym.t * 'a) list -> IndexTerms.t -> IndexTerms.t list -> IndexTerms.t + + val unroll_once : t -> IndexTerms.t list -> IndexTerms.t option + + val try_open : t -> IndexTerms.t list -> IndexTerms.t option + + val is_interesting : t -> bool +end + +module Clause : sig + type t = + { loc : Locations.t; + guard : IndexTerms.t; + packing_ft : LogicalArgumentTypes.packing_ft + } + + val pp : t -> Pp.document + + val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t + + val lrt : IndexTerms.t -> IndexTerms.t LogicalArgumentTypes.t -> LogicalReturnTypes.t +end + +module Predicate : sig + type t = + { loc : Locations.t; + pointer : Sym.t; + iargs : (Sym.t * BaseTypes.t) list; + oarg_bt : BaseTypes.t; + clauses : Clause.t list option + } + + val pp : t -> Pp.document + + val instantiate : t -> IndexTerms.t -> IndexTerms.t list -> Clause.t list option + + val identify_right_clause + : (LogicalConstraints.logical_constraint -> [< `False | `True ]) -> + t -> + IndexTerms.t -> + IndexTerms.t list -> + Clause.t option + + val given_to_solver : t -> bool +end + +val alloc : Predicate.t + +val is_interesting : Predicate.t -> bool diff --git a/backend/cn/lib/executable_spec_internal.ml b/backend/cn/lib/executable_spec_internal.ml index f6cf6d066..d1cb0a530 100644 --- a/backend/cn/lib/executable_spec_internal.ml +++ b/backend/cn/lib/executable_spec_internal.ml @@ -353,8 +353,7 @@ let bt_is_record_or_tuple = function BT.Record _ | BT.Tuple _ -> true | _ -> fal let fns_and_preds_with_record_rt (funs, preds) = let funs' = List.filter - (fun (_, (def : Definition.Function.definition)) -> - bt_is_record_or_tuple def.return_bt) + (fun (_, (def : Definition.Function.t)) -> bt_is_record_or_tuple def.return_bt) funs in let fun_syms = List.map (fun (fn_sym, _) -> fn_sym) funs' in @@ -369,7 +368,7 @@ let fns_and_preds_with_record_rt (funs, preds) = let generate_c_functions_internal (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) - (logical_predicates : (Sym.t * Definition.Function.definition) list) + (logical_predicates : (Sym.t * Definition.Function.t) list) = let ail_funs_and_records = List.map diff --git a/backend/cn/lib/executable_spec_records.ml b/backend/cn/lib/executable_spec_records.ml index f16abd0fe..1eb25410a 100644 --- a/backend/cn/lib/executable_spec_records.ml +++ b/backend/cn/lib/executable_spec_records.ml @@ -140,9 +140,7 @@ let rec populate ?cn_sym bt = let add_records_to_map_from_fns_and_preds cn_funs cn_preds = let fun_syms_and_ret_types = - List.map - (fun (sym, (def : Definition.Function.definition)) -> (sym, def.return_bt)) - cn_funs + List.map (fun (sym, (def : Definition.Function.t)) -> (sym, def.return_bt)) cn_funs in let pred_syms_and_ret_types = List.map (fun (sym, (def : Definition.Predicate.t)) -> (sym, def.oarg_bt)) cn_preds diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index d9354a371..e42c39f12 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -353,7 +353,6 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra match extras.request with | None -> [] | Some req -> - let open Definition in (match Req.get_name req with | Owned _ -> [] | PName pname -> diff --git a/backend/cn/lib/global.ml b/backend/cn/lib/global.ml index 630d5a472..3aa48779a 100644 --- a/backend/cn/lib/global.ml +++ b/backend/cn/lib/global.ml @@ -10,7 +10,7 @@ type t = datatype_order : Sym.t list list option; fun_decls : (Locations.t * AT.ft option * Sctypes.c_concrete_sig) Sym.Map.t; resource_predicates : Definition.Predicate.t Sym.Map.t; - logical_functions : Definition.Function.definition Sym.Map.t; + logical_functions : Definition.Function.t Sym.Map.t; lemmata : (Locations.t * AT.lemmat) Sym.Map.t } diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index dc44cebc5..e648918ba 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -407,8 +407,8 @@ let it_adjust (global : Global.t) it = | IT.Apply (name, args) -> let open Definition.Function in let def = Sym.Map.find name global.logical_functions in - (match (def.definition, def.emit_coq) with - | Def body, false -> f (open_fun def.args body args) + (match (def.body, def.emit_coq) with + | Def body, false -> f (open_ def.args body args) | _ -> t) | IT.Good (ct, t2) -> if Option.is_some (Sctypes.is_struct_ctype ct) then @@ -781,7 +781,7 @@ let ensure_pred global list_mono loc name aux = let open Definition.Function in let def = Sym.Map.find name global.Global.logical_functions in let inf = (loc, Pp.typ (Pp.string "pred") (Sym.pp name)) in - match def.definition with + match def.body with | Uninterp -> gen_ensure 1 @@ -852,10 +852,10 @@ let rec unfold_if_possible global it = match it with | IT (IT.Apply (name, args), _, _) -> let def = Option.get (Global.get_logical_function_def global name) in - (match def.definition with + (match def.body with | Rec_Def _ -> it | Uninterp -> it - | Def body -> unfold_if_possible global (open_fun def.args body args)) + | Def body -> unfold_if_possible global (open_ def.args body args)) | _ -> it diff --git a/backend/cn/lib/mucore.ml b/backend/cn/lib/mucore.ml index 538e636b1..6c417d27c 100644 --- a/backend/cn/lib/mucore.ml +++ b/backend/cn/lib/mucore.ml @@ -429,7 +429,7 @@ type 'TY file = stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; resource_predicates : (Sym.t * Definition.Predicate.t) list; - logical_predicates : (Sym.t * Definition.Function.definition) list; + logical_predicates : (Sym.t * Definition.Function.t) list; datatypes : (Sym.t * datatype) list; lemmata : (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list; call_funinfo : (Sym.t, Sctypes.c_concrete_sig) Pmap.map diff --git a/backend/cn/lib/mucore.mli b/backend/cn/lib/mucore.mli index fac5c3c23..3d69d39c6 100644 --- a/backend/cn/lib/mucore.mli +++ b/backend/cn/lib/mucore.mli @@ -332,7 +332,7 @@ type 'TY file = stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; resource_predicates : (Sym.t * Definition.Predicate.t) list; - logical_predicates : (Sym.t * Definition.Function.definition) list; + logical_predicates : (Sym.t * Definition.Function.t) list; datatypes : (Sym.t * datatype) list; lemmata : (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list; call_funinfo : (Sym.t, Sctypes.c_concrete_sig) Pmap.map diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index fee01a4df..aeeb9da63 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -90,7 +90,7 @@ let packing_ft loc global provable ret = Some at | PName pn -> let def = Sym.Map.find pn global.resource_predicates in - (match identify_right_clause provable def ret.pointer ret.iargs with + (match Predicate.identify_right_clause provable def ret.pointer ret.iargs with | None -> None | Some right_clause -> Some right_clause.packing_ft)) | Q _ -> None diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index a81d0c287..432f55f7d 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -597,7 +597,7 @@ module IndexTerms = struct t else ( let def = Sym.Map.find name simp_ctxt.global.logical_functions in - match Definition.Function.try_open_fun def args with + match Definition.Function.try_open def args with | Some inlined -> aux inlined | None -> t) | _ -> diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 79556766d..141293aae 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -1002,8 +1002,8 @@ let rec translate_term s iterm = | MapDef _ -> failwith "MapDef" | Apply (name, args) -> let def = Option.get (get_logical_function_def s.globals name) in - (match def.definition with - | Def body -> translate_term s (Definition.Function.open_fun def.args body args) + (match def.body with + | Def body -> translate_term s (Definition.Function.open_ def.args body args) | _ -> let do_arg arg = translate_base_type (IT.basetype arg) in let args_ts = List.map do_arg args in diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 94b3829b0..9ddb9d988 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -764,11 +764,11 @@ module PartialEvaluation = struct eval_aux (divisible_ (addr, align) here) | Apply (fsym, its) -> (match List.assoc_opt Sym.equal fsym prog5.logical_predicates with - | Some { args; definition = Def it_body; _ } - | Some { args; definition = Rec_Def it_body; _ } -> + | Some { args; body = Def it_body; _ } | Some { args; body = Rec_Def it_body; _ } + -> return @@ IT.subst (IT.make_subst (List.combine (List.map fst args) its)) it_body - | Some { definition = Uninterp; _ } -> + | Some { body = Uninterp; _ } -> Error ("Function " ^ Sym.pp_string fsym ^ " is uninterpreted") | None -> Error ("Function " ^ Sym.pp_string fsym ^ " was not found")) | Let ((x, it_v), it_rest) -> @@ -1018,9 +1018,9 @@ module PartialEvaluation = struct * substitution, diverging. As such, we force strict evaluation of recursive calls *) (match List.assoc_opt Sym.equal fsym prog5.logical_predicates with - | Some { definition = Def _; _ } -> f it - | Some { definition = Rec_Def _; _ } -> f ~mode:Strict it - | Some { definition = Uninterp; _ } | None -> it) + | Some { body = Def _; _ } -> f it + | Some { body = Rec_Def _; _ } -> f ~mode:Strict it + | Some { body = Uninterp; _ } | None -> it) | _ -> f it in IT.map_term_post aux it diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 63d628ed4..b46997b96 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -118,7 +118,7 @@ val get_lemma : Locations.t -> Sym.t -> (Locations.t * Global.AT.lemmat) m val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t m -val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.definition m +val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t m val add_struct_decl : Sym.t -> Memory.struct_layout -> unit m @@ -131,7 +131,7 @@ val add_lemma : Sym.t -> Locations.t * ArgumentTypes.lemmat -> unit m val add_resource_predicate : Sym.t -> Definition.Predicate.t -> unit m -val add_logical_function : Sym.t -> Definition.Function.definition -> unit m +val add_logical_function : Sym.t -> Definition.Function.t -> unit m val add_datatype : Sym.t -> BaseTypes.dt_info -> unit m diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index e49d08a1c..527f33f96 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -2299,9 +2299,7 @@ end module WLFD = struct open Definition.Function - let welltyped - ({ loc; args; return_bt; emit_coq; definition } : Definition.Function.definition) - = + let welltyped ({ loc; args; return_bt; emit_coq; body } : Definition.Function.t) = (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure (let@ args = @@ -2313,8 +2311,8 @@ module WLFD = struct args in let@ return_bt = WBT.is_bt loc return_bt in - let@ definition = - match definition with + let@ body = + match body with | Def body -> let@ body = WIT.check loc return_bt body in return (Def body) @@ -2323,7 +2321,7 @@ module WLFD = struct return (Rec_Def body) | Uninterp -> return Uninterp in - return { loc; args; return_bt; emit_coq; definition }) + return { loc; args; return_bt; emit_coq; body }) end module WLemma = struct From 4424513befd5759b4a31b85eacb0dfc06213fe1d Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 10 Dec 2024 23:08:49 +0000 Subject: [PATCH 101/148] Clarify SMT limitation --- backend/cn/lib/compile.ml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 94c498f0c..7a6c01b07 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -331,9 +331,8 @@ let register_cn_functions env (defs : cn_function list) = let add_datatype_info env (dt : cn_datatype) = Pp.debug 2 (lazy (Pp.item "translating datatype declaration" (Sym.pp dt.cn_dt_name))); - (* This seems to require that variables aren't simply unique to the constructor, but to - the entire datatype declaration. This is weird, and is probably an arbitrary - restriction that should be lifted, but it will require effort. *) + (* SMT format constraints seem to require variables to be unique to the + datatype, not just the constructor. *) let add_param m (nm, ty) = match StringMap.find_opt (Id.s nm) m with | None -> @@ -343,7 +342,9 @@ let add_datatype_info env (dt : cn_datatype) = { loc = Id.loc nm; msg = Generic - (!^"Re-using member name" ^^^ Id.pp nm ^^^ !^"within datatype definition.") + (!^"Re-using member name" + ^^^ Id.pp nm + ^^^ !^"within datatype definition (SMT limitation).") } in let@ all_params = From a429a408dc28ffeefe8cbf3bf96a0db4be8e6f04 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 11 Dec 2024 15:24:14 +0000 Subject: [PATCH 102/148] CN VIP: Clarify pointer equality tests The rule should warn when it cannot rule out ambiguity, rather than when it can prove it. --- backend/cn/lib/check.ml | 10 +++++----- ...r_dataflow_direct_bytewise.pass.c.no_annot | 19 ++++++++++++++++++- .../pointer_from_integer_1ig.annot.c.no_annot | 3 +++ ...ter_from_integer_1pg.unprovable.c.no_annot | 3 +++ .../provenance_equality_auto_yx.nondet.c | 2 ++ ...venance_equality_auto_yx.nondet.c.no_annot | 3 +++ ...ce_equality_auto_yx.nondet.c.non_det_false | 7 +++++-- ...nce_equality_auto_yx.nondet.c.non_det_true | 7 +++++-- .../provenance_equality_global_fn_yx.nondet.c | 8 ++++++-- ...ce_equality_global_fn_yx.nondet.c.no_annot | 3 +++ ...uality_global_fn_yx.nondet.c.non_det_false | 7 +++++-- ...quality_global_fn_yx.nondet.c.non_det_true | 7 +++++-- .../provenance_equality_global_yx.nondet.c | 4 +++- ...nance_equality_global_yx.nondet.c.no_annot | 3 +++ ..._equality_global_yx.nondet.c.non_det_false | 7 +++++-- ...e_equality_global_yx.nondet.c.non_det_true | 7 +++++-- 16 files changed, 79 insertions(+), 21 deletions(-) diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 3f0d54d36..eaf3ea11a 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -1337,13 +1337,13 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in let@ provable = provable loc in let@ () = - match provable @@ LC.T ambiguous with - | `False -> return () - | `True -> + match provable @@ LC.T (not_ ambiguous here) with + | `True -> return () + | `False -> let msg = Printf.sprintf - "ambiguous pointer %sequality case: addresses equal, but \ - provenances differ" + "Cannot rule out ambiguous pointer %sequality case (addresses \ + equal, but provenances differ)" case in warn loc !^msg; diff --git a/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot index 2c7128919..19236f25e 100644 --- a/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot @@ -1 +1,18 @@ -TIMEOUT +return code: 0 +tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:28:5: warning: CN pointer equality is not the same as C's (will not warn again). Please use `ptr_eq` or `is_null` (maybe `addr_eq`). + src == array_shift(src_start, n_start - n); + ~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:48:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:49:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Block(&q); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:52:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:53:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/2]: user_memcpy -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot index 4519854db..39635ab21 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot @@ -1,4 +1,7 @@ return code: 1 +tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c:15:7: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + if (p==&j) { + ~^~~~ [1/2]: f -- fail [2/2]: main -- pass tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c:16:5: error: Missing resource for writing diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot index cbcac5e51..6944ec91f 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot @@ -1,4 +1,7 @@ return code: 1 +tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c:6:7: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + if (p==&j) + ~^~~~ [1/2]: f -- fail [2/2]: main -- pass tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c:7:5: error: Missing resource for writing diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c index af233ac8a..9b6ece157 100644 --- a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c @@ -1,7 +1,9 @@ //CN_VIP #include //CN_VIP #include +#include "cn_lemmas.h" int main() { int y=2, x=1; + /*CN_VIP*//*@ apply assert_equal((u64)&y, (u64)&x + sizeof); @*/ int *p = &x + 1; int *q = &y; //CN_VIP printf("Addresses: p=%p q=%p\n",(void*)p,(void*)q); diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot index 363cf45d8..91eceb35e 100644 --- a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot @@ -1,2 +1,5 @@ return code: 0 +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false index 3dbcf5e08..7f4a120bc 100644 --- a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false @@ -1,9 +1,12 @@ return code: 1 +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ [1/1]: main -- fail -tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:13:17: error: Unprovable constraint +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:15:17: error: Unprovable constraint /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ -Constraint from tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:13:17: +Constraint from tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:15:17: /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ State file: file:///tmp/state__provenance_equality_auto_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true index b82c8b7d3..5de47f548 100644 --- a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true @@ -1,9 +1,12 @@ return code: 1 +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ [1/1]: main -- fail -tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:11:17: error: Unprovable constraint +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:13:17: error: Unprovable constraint /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ -Constraint from tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:11:17: +Constraint from tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:13:17: /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ State file: file:///tmp/state__provenance_equality_auto_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c index 27f652d89..612f4c288 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c @@ -1,7 +1,9 @@ //CN_VIP #include #include int y=2, x=1; -void f(int* p, int* q) { +void f(int* p, int* q) +/*CN_VIP*//*@ requires (u64)p == (u64)q; @*/ +{ _Bool b = (p==q); // can this be false even with identical addresses? //CN_VIP printf("(p==q) = %s\n", b?"true":"false"); @@ -14,7 +16,9 @@ void f(int* p, int* q) { #endif return; } -int main() { +int main() +/*CN_VIP*//*@ accesses x; requires (u64)&y == (u64)&x + sizeof; @*/ +{ int *p = &x + 1; int *q = &y; //CN_VIP printf("Addresses: p=%p q=%p\n",(void*)p,(void*)q); diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot index 3e567df0b..ec6e63b46 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot @@ -1,3 +1,6 @@ return code: 0 +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:7:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ [1/2]: f -- pass [2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false index 1099a5c7e..a2c6a3cbd 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false @@ -1,10 +1,13 @@ return code: 1 +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:7:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ [1/2]: f -- fail [2/2]: main -- pass -tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:11:17: error: Unprovable constraint +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:13:17: error: Unprovable constraint /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ -Constraint from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:11:17: +Constraint from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:13:17: /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ State file: file:///tmp/state__provenance_equality_global_fn_yx.nondet.c__f.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true index 47b9a9b7c..accb43ccd 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true @@ -1,10 +1,13 @@ return code: 1 +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:7:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ [1/2]: f -- fail [2/2]: main -- pass -tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:9:17: error: Unprovable constraint +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:11:17: error: Unprovable constraint /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ -Constraint from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:9:17: +Constraint from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:11:17: /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ State file: file:///tmp/state__provenance_equality_global_fn_yx.nondet.c__f.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c index 41144f560..7a5453ece 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c @@ -1,7 +1,9 @@ //CN_VIP #include #include int y=2, x=1; -int main() { +int main() +/*CN_VIP*//*@ accesses x; requires (u64)&y == (u64)&x + sizeof; @*/ +{ int *p = &x + 1; int *q = &y; //CN_VIP printf("Addresses: p=%p q=%p\n",(void*)p,(void*)q); diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot index 363cf45d8..2c6a629eb 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot @@ -1,2 +1,5 @@ return code: 0 +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false index f407d5321..479583e3a 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false @@ -1,9 +1,12 @@ return code: 1 +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ [1/1]: main -- fail -tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:14:17: error: Unprovable constraint +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:16:17: error: Unprovable constraint /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ -Constraint from tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:14:17: +Constraint from tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:16:17: /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ State file: file:///tmp/state__provenance_equality_global_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true index d93691619..3cfb2aa15 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true @@ -1,9 +1,12 @@ return code: 1 +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ [1/1]: main -- fail -tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:12:17: error: Unprovable constraint +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:14:17: error: Unprovable constraint /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ -Constraint from tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:12:17: +Constraint from tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:14:17: /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP ^~~~~~~~~~~~~~~~~~ State file: file:///tmp/state__provenance_equality_global_yx.nondet.c__main.html From 6644fb4ad7773824246ad953ed8efe42472cab6b Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 11 Dec 2024 18:18:21 +0000 Subject: [PATCH 103/148] CN VIP: Recategorise 'unprovable' tests as error --- ...p.unprovable.c => pointer_from_integer_1p.error.c} | 0 .../pointer_from_integer_1p.error.c.no_annot | 8 ++++++++ .../pointer_from_integer_1p.unprovable.c.no_annot | 8 -------- ....unprovable.c => pointer_from_integer_1pg.error.c} | 0 .../pointer_from_integer_1pg.error.c.no_annot | 11 +++++++++++ .../pointer_from_integer_1pg.unprovable.c.no_annot | 11 ----------- ..._2.unprovable.c => pointer_from_integer_2.error.c} | 0 .../pointer_from_integer_2.error.c.no_annot | 8 ++++++++ .../pointer_from_integer_2.unprovable.c.no_annot | 8 -------- ...g.unprovable.c => pointer_from_integer_2g.error.c} | 0 .../pointer_from_integer_2g.error.c.no_annot | 8 ++++++++ .../pointer_from_integer_2g.unprovable.c.no_annot | 8 -------- 12 files changed, 35 insertions(+), 35 deletions(-) rename tests/cn_vip_testsuite/{pointer_from_integer_1p.unprovable.c => pointer_from_integer_1p.error.c} (100%) create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1p.error.c.no_annot delete mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c.no_annot rename tests/cn_vip_testsuite/{pointer_from_integer_1pg.unprovable.c => pointer_from_integer_1pg.error.c} (100%) create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c.no_annot delete mode 100644 tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot rename tests/cn_vip_testsuite/{pointer_from_integer_2.unprovable.c => pointer_from_integer_2.error.c} (100%) create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_2.error.c.no_annot delete mode 100644 tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c.no_annot rename tests/cn_vip_testsuite/{pointer_from_integer_2g.unprovable.c => pointer_from_integer_2g.error.c} (100%) create mode 100644 tests/cn_vip_testsuite/pointer_from_integer_2g.error.c.no_annot delete mode 100644 tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c.no_annot diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_1p.error.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_1p.error.c diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1p.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1p.error.c.no_annot new file mode 100644 index 000000000..7818545f5 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1p.error.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1p.error.c:6:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(p) +State file: file:///tmp/state__pointer_from_integer_1p.error.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c.no_annot deleted file mode 100644 index c552fb4bf..000000000 --- a/tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c.no_annot +++ /dev/null @@ -1,8 +0,0 @@ -return code: 1 -[1/2]: f -- fail -[2/2]: main -- pass -tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c:6:3: error: Missing resource for writing - *p=7; - ~~^~ -Resource needed: Block(p) -State file: file:///tmp/state__pointer_from_integer_1p.unprovable.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c.no_annot new file mode 100644 index 000000000..7cf81a333 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c.no_annot @@ -0,0 +1,11 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c:6:7: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + if (p==&j) + ~^~~~ +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c:7:5: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(p) +State file: file:///tmp/state__pointer_from_integer_1pg.error.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot deleted file mode 100644 index 6944ec91f..000000000 --- a/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c.no_annot +++ /dev/null @@ -1,11 +0,0 @@ -return code: 1 -tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c:6:7: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) - if (p==&j) - ~^~~~ -[1/2]: f -- fail -[2/2]: main -- pass -tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c:7:5: error: Missing resource for writing - *p=7; - ~~^~ -Resource needed: Block(p) -State file: file:///tmp/state__pointer_from_integer_1pg.unprovable.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_2.error.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_2.error.c diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_2.error.c.no_annot new file mode 100644 index 000000000..59f26202e --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_2.error.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_2.error.c:7:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_2.error.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c.no_annot deleted file mode 100644 index d4af4fbc2..000000000 --- a/tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c.no_annot +++ /dev/null @@ -1,8 +0,0 @@ -return code: 1 -[1/2]: f -- fail -[2/2]: main -- pass -tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c:7:3: error: Missing resource for writing - *p=7; - ~~^~ -Resource needed: Block(intToPtr) -State file: file:///tmp/state__pointer_from_integer_2.unprovable.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_2g.error.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_2g.error.c diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2g.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_2g.error.c.no_annot new file mode 100644 index 000000000..98990b55a --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_2g.error.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_2g.error.c:7:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_2g.error.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c.no_annot deleted file mode 100644 index f9d410b46..000000000 --- a/tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c.no_annot +++ /dev/null @@ -1,8 +0,0 @@ -return code: 1 -[1/2]: f -- fail -[2/2]: main -- pass -tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c:7:3: error: Missing resource for writing - *p=7; - ~~^~ -Resource needed: Block(intToPtr) -State file: file:///tmp/state__pointer_from_integer_2g.unprovable.c__f.html From 3d43d4f73cb137bd326e24a0f3b38b7bacf62b75 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Wed, 11 Dec 2024 14:56:39 -0500 Subject: [PATCH 104/148] [CN-Test-Gen] Shuffle random size splits (#760) --- backend/cn/lib/testGeneration/genCodeGen.ml | 3 +- runtime/libcn/include/cn-testing/dsl.h | 14 +- runtime/libcn/include/cn-testing/rand.h | 65 +++++++- runtime/libcn/src/cn-testing/rand.c | 174 ++++++++++++++++++++ runtime/libcn/src/cn-testing/uniform.c | 124 ++------------ tests/run-cn-test-gen.sh | 2 +- 6 files changed, 258 insertions(+), 124 deletions(-) diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index 37ffb16d5..5e0ef5592 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -453,7 +453,6 @@ let rec compile_term | SplitSize { rest; _ } when not (TestGenConfig.is_random_size_splits ()) -> compile_term sigma ctx name rest | SplitSize { marker_var; syms; path_vars; last_var; rest } -> - let e_ty = mk_expr (AilEident (Sym.fresh_named (name_of_bt name Memory.size_bt))) in let e_tmp = mk_expr (AilEident marker_var) in let e_size = mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")) in let syms_l = syms |> Sym.Set.to_seq |> List.of_seq in @@ -484,7 +483,7 @@ let rec compile_term (mk_expr (AilEcall ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_SPLIT_END")), - [ e_ty; e_tmp; e_size; mk_expr (AilEident last_var) ] + [ e_tmp; e_size; mk_expr (AilEident last_var) ] @ List.map wrap_to_string (List.of_seq (Sym.Set.to_seq path_vars)) @ [ mk_expr (AilEconst ConstantNull) ] ))) ] diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index 86153b02c..f6ee72a49 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -248,23 +248,17 @@ count += 1; \ } -#define CN_GEN_SPLIT_END(ty, tmp, size, last_var, ...) \ +#define CN_GEN_SPLIT_END(tmp, size, last_var, ...) \ if (count >= size) { \ cn_gen_backtrack_depth_exceeded(); \ char* toAdd[] = { __VA_ARGS__ }; \ cn_gen_backtrack_relevant_add_many(toAdd); \ goto cn_label_##last_var##_backtrack; \ } \ - size_t used = 0; \ - for (int i = 0; i < count - 1; i++) { \ - int left = size - (count - i) + 1 - used; \ - ty* one = convert_to_##ty(1); \ - ty* bound = convert_to_##ty(left + 1); \ - ty* rnd = cn_gen_range_##ty(one, bound); \ - *vars[i] = convert_from_##ty(rnd); \ - used += convert_from_##ty(rnd); \ + cn_gen_split(size - count - 1, vars, count); \ + for (int i = 0; i < count; i++) { \ + *(vars[i]) = *(vars[i]) + 1; \ } \ - *vars[count - 1] = size - 1 - used; \ } \ if (0) { \ cn_label_##tmp##_backtrack: \ diff --git a/runtime/libcn/include/cn-testing/rand.h b/runtime/libcn/include/cn-testing/rand.h index c2e47ef30..a746488cb 100644 --- a/runtime/libcn/include/cn-testing/rand.h +++ b/runtime/libcn/include/cn-testing/rand.h @@ -8,9 +8,72 @@ extern "C" { #endif void cn_gen_srand(uint64_t seed); - uint64_t cn_gen_rand(void); + uint8_t cn_gen_uniform_u8(uint8_t); + uint16_t cn_gen_uniform_u16(uint16_t); + uint32_t cn_gen_uniform_u32(uint32_t); + uint64_t cn_gen_uniform_u64(uint64_t); + + int8_t cn_gen_uniform_i8(uint8_t); + int16_t cn_gen_uniform_i16(uint16_t); + int32_t cn_gen_uniform_i32(uint32_t); + int64_t cn_gen_uniform_i64(uint64_t); + + uint8_t cn_gen_range_u8(uint8_t, uint8_t); + uint16_t cn_gen_range_u16(uint16_t, uint16_t); + uint32_t cn_gen_range_u32(uint32_t, uint32_t); + uint64_t cn_gen_range_u64(uint64_t, uint64_t); + + int8_t cn_gen_range_i8(int8_t, int8_t); + int16_t cn_gen_range_i16(int16_t, int16_t); + int32_t cn_gen_range_i32(int32_t, int32_t); + int64_t cn_gen_range_i64(int64_t, int64_t); + + uint8_t cn_gen_lt_u8(uint8_t); + uint16_t cn_gen_lt_u16(uint16_t); + uint32_t cn_gen_lt_u32(uint32_t); + uint64_t cn_gen_lt_u64(uint64_t); + + int8_t cn_gen_lt_i8(int8_t); + int16_t cn_gen_lt_i16(int16_t); + int32_t cn_gen_lt_i32(int32_t); + int64_t cn_gen_lt_i64(int64_t); + + uint8_t cn_gen_ge_u8(uint8_t); + uint16_t cn_gen_ge_u16(uint16_t); + uint32_t cn_gen_ge_u32(uint32_t); + uint64_t cn_gen_ge_u64(uint64_t); + + int8_t cn_gen_ge_i8(int8_t); + int16_t cn_gen_ge_i16(int16_t); + int32_t cn_gen_ge_i32(int32_t); + int64_t cn_gen_ge_i64(int64_t); + + uint8_t cn_gen_mult_range_u8(uint8_t, uint8_t, uint8_t); + uint16_t cn_gen_mult_range_u16(uint16_t, uint16_t, uint16_t); + uint32_t cn_gen_mult_range_u32(uint32_t, uint32_t, uint32_t); + uint64_t cn_gen_mult_range_u64(uint64_t, uint64_t, uint64_t); + + int8_t cn_gen_mult_range_i8(int8_t, int8_t, int8_t); + int16_t cn_gen_mult_range_i16(int16_t, int16_t, int16_t); + int32_t cn_gen_mult_range_i32(int32_t, int32_t, int32_t); + int64_t cn_gen_mult_range_i64(int64_t, int64_t, int64_t); + + uint8_t cn_gen_mult_u8(uint8_t); + uint16_t cn_gen_mult_u16(uint16_t); + uint32_t cn_gen_mult_u32(uint32_t); + uint64_t cn_gen_mult_u64(uint64_t); + + int8_t cn_gen_mult_i8(int8_t); + int16_t cn_gen_mult_i16(int16_t); + int32_t cn_gen_mult_i32(int32_t); + int64_t cn_gen_mult_i64(int64_t); + + void cn_gen_shuffle(void* arr, size_t len, size_t size); + + void cn_gen_split(size_t n, size_t* arr[], size_t len); + uint64_t cn_gen_rand_retry(void); typedef void* cn_gen_rand_checkpoint; diff --git a/runtime/libcn/src/cn-testing/rand.c b/runtime/libcn/src/cn-testing/rand.c index 596c17997..92f009c80 100644 --- a/runtime/libcn/src/cn-testing/rand.c +++ b/runtime/libcn/src/cn-testing/rand.c @@ -2,6 +2,7 @@ #include #include #include +#include #include @@ -94,6 +95,179 @@ uint64_t genrand(void) { // End of Mersenne twister // ///////////////////////////// +// Sized generation according to Lemire: https://doi.org/10.1145/3230636 +#define UNSIGNED_GEN(sm, lg) \ +uint##sm##_t cn_gen_uniform_u##sm(uint##sm##_t s) { \ + uint##sm##_t x = cn_gen_rand(); \ + if (s == 0) { \ + return x; \ + } \ + \ + uint##lg##_t m = (uint##lg##_t)x * (uint##lg##_t)s; \ + uint##sm##_t l = m; /* m % pow(2, sm) */ \ + if (l < s) { \ + uint##lg##_t t = (UINT##sm##_MAX - (s - 1)) % s; \ + while (l < t) { \ + x = cn_gen_rand(); \ + m = x * s; \ + l = m; /* m % pow(2, sm) */ \ + } \ + } \ + return m >> sm; \ +} + +UNSIGNED_GEN(8, 16); +UNSIGNED_GEN(16, 32); +UNSIGNED_GEN(32, 64); + +// OpenJDK 9 implementation, according to the definition in Lemire. +uint64_t cn_gen_uniform_u64(uint64_t s) { + uint64_t x = cn_gen_rand(); + if (s == 0) { + return x; + } + + uint64_t r = x % s; + while (x - r > UINT64_MAX - (s - 1)) { + x = cn_gen_rand(); + r = x % s; + } + return r; +} + +#define SIGNED_GEN(sm) \ +int##sm##_t cn_gen_uniform_i##sm(uint##sm##_t s) { \ + uint##sm##_t x = cn_gen_uniform_u##sm(s); \ + if (s == 0) { \ + return x; \ + } \ + uint##sm##_t offset = (s + 1) >> 2; \ + return x - offset; \ +} + +SIGNED_GEN(8); +SIGNED_GEN(16); +SIGNED_GEN(32); +SIGNED_GEN(64); + +#define RANGE_GEN(sm) \ +uint##sm##_t cn_gen_range_u##sm(uint##sm##_t min, uint##sm##_t max) { \ + uint##sm##_t x = cn_gen_uniform_u##sm(max - min); \ + return x + min; \ +} \ +int##sm##_t cn_gen_range_i##sm(int##sm##_t min, int##sm##_t max) { \ + return cn_gen_range_u##sm(min, max); \ +} + +RANGE_GEN(8); +RANGE_GEN(16); +RANGE_GEN(32); +RANGE_GEN(64); + +#define INEQ_GEN(sm)\ +uint##sm##_t cn_gen_lt_u##sm(uint##sm##_t max) { \ + return cn_gen_range_u##sm(0, max); \ +} \ +int##sm##_t cn_gen_lt_i##sm(int##sm##_t max) { \ + return cn_gen_range_i##sm(INT##sm##_MIN, max); \ +} \ +uint##sm##_t cn_gen_ge_u##sm(uint##sm##_t min) { \ + return cn_gen_range_u##sm(min, 0); \ +} \ +int##sm##_t cn_gen_ge_i##sm(int##sm##_t min) { \ + return cn_gen_range_i##sm(min, INT##sm##_MIN); \ +} + +INEQ_GEN(8); +INEQ_GEN(16); +INEQ_GEN(32); +INEQ_GEN(64); + +#define MULT_RANGE_GEN(sm) \ +uint##sm##_t cn_gen_mult_range_u##sm( \ + uint##sm##_t mul, \ + uint##sm##_t min, \ + uint##sm##_t max \ +) { \ + assert(mul != 0); \ + uint##sm##_t x = cn_gen_range_u##sm(min / mul, max / mul + (max % mul != 0)); \ + return x * mul; \ +} \ +int##sm##_t cn_gen_mult_range_i##sm( \ + int##sm##_t mul, \ + int##sm##_t min, \ + int##sm##_t max \ +) { \ + assert(mul != 0); \ + int##sm##_t x = cn_gen_range_i##sm(min / mul, max / mul + (max % mul != 0)); \ + return x * mul; \ +} + +MULT_RANGE_GEN(8); +MULT_RANGE_GEN(16); +MULT_RANGE_GEN(32); +MULT_RANGE_GEN(64); + +#define MULT_GEN(sm) \ +uint##sm##_t cn_gen_mult_u##sm(uint##sm##_t mul) { \ + return cn_gen_mult_range_u##sm(mul, 0, UINT##sm##_MAX); \ +} \ +int##sm##_t cn_gen_mult_i##sm(int##sm##_t mul) { \ + return cn_gen_mult_range_i##sm(mul, INT##sm##_MIN, INT##sm##_MAX); \ +} + +MULT_GEN(8); +MULT_GEN(16); +MULT_GEN(32); +MULT_GEN(64); + +void cn_gen_shuffle(void* arr, size_t len, size_t size) { + // byte size is implementation-defined (6.5.3.4, bullet 2) + // but `sizeof(char) == 1` is guaranteed. + char tmp[size]; + char* p = arr; + + for (int i = len - 1; i >= 0; i--) { + uint8_t j = cn_gen_range_u8(0, i + 1); + memcpy(tmp, arr + i * size, size); + memcpy(arr + i * size, arr + j * size, size); + memcpy(arr + j * size, tmp, size); + } +} + +static int comp_size_t(const void* x, const void* y) { + size_t a = *(const size_t*)x; + size_t b = *(const size_t*)y; + + if (a < b) return -1; + if (b > a) return 1; + return 0; +} + +void cn_gen_split(size_t n, size_t* arr[], size_t len) { + if (len == 1) { + *(arr[0]) = n; + return; + } + + if (len == 2) { + *(arr[0]) = (size_t)cn_gen_range_u64(0, n + 1); + *(arr[1]) = n - *(arr[0]); + return; + } + + int used = 0; + for (int i = 0; i < len - 1; i++) { + int left = n - (len - i) + 1 - used; + size_t rnd = (size_t)cn_gen_range_u64(1, left + 1); + *(arr[i]) = rnd; + used += rnd; + } + *(arr[len - 1]) = n - 1 - used; + + cn_gen_shuffle(&arr, len, sizeof(size_t*)); +} + struct choice_list { uint64_t choice; struct choice_list* next; diff --git a/runtime/libcn/src/cn-testing/uniform.c b/runtime/libcn/src/cn-testing/uniform.c index c69b0282a..79a184854 100644 --- a/runtime/libcn/src/cn-testing/uniform.c +++ b/runtime/libcn/src/cn-testing/uniform.c @@ -4,68 +4,13 @@ #include #include -// Sized generation according to Lemire: https://doi.org/10.1145/3230636 -#define UNSIGNED_GEN(sm, lg) \ -static uint##sm##_t uniform_u##sm(uint##sm##_t s) { \ - uint##sm##_t x = cn_gen_rand(); \ - if (s == 0) { \ - return x; \ - } \ - \ - uint##lg##_t m = (uint##lg##_t)x * (uint##lg##_t)s; \ - uint##sm##_t l = m; /* m % pow(2, sm) */ \ - if (l < s) { \ - uint##lg##_t t = (UINT##sm##_MAX - (s - 1)) % s; \ - while (l < t) { \ - x = cn_gen_rand(); \ - m = x * s; \ - l = m; /* m % pow(2, sm) */ \ - } \ - } \ - return m >> sm; \ -} - -UNSIGNED_GEN(8, 16); -UNSIGNED_GEN(16, 32); -UNSIGNED_GEN(32, 64); - -// OpenJDK 9 implementation, according to the definition in Lemire. -static uint64_t uniform_u64(uint64_t s) { - uint64_t x = cn_gen_rand(); - if (s == 0) { - return x; - } - - uint64_t r = x % s; - while (x - r > UINT64_MAX - (s - 1)) { - x = cn_gen_rand(); - r = x % s; - } - return r; -} - -#define SIGNED_GEN(sm) \ -static int##sm##_t uniform_i##sm(uint##sm##_t s) { \ - uint##sm##_t x = uniform_u##sm(s); \ - if (s == 0) { \ - return x; \ - } \ - uint##sm##_t offset = (s + 1) >> 2; \ - return x - offset; \ -} - -SIGNED_GEN(8); -SIGNED_GEN(16); -SIGNED_GEN(32); -SIGNED_GEN(64); - #define BITS_GEN(sm) \ cn_bits_u##sm* cn_gen_uniform_cn_bits_u##sm(uint64_t sz) { \ - return convert_to_cn_bits_u##sm(uniform_u##sm(sz)); \ + return convert_to_cn_bits_u##sm(cn_gen_uniform_u##sm(sz)); \ } \ \ cn_bits_i##sm* cn_gen_uniform_cn_bits_i##sm(uint64_t sz) { \ - return convert_to_cn_bits_i##sm(uniform_i##sm(sz)); \ + return convert_to_cn_bits_i##sm(cn_gen_uniform_i##sm(sz)); \ } BITS_GEN(8); @@ -74,18 +19,11 @@ BITS_GEN(32); BITS_GEN(64); #define RANGE_GEN(sm) \ -uint##sm##_t range_u##sm(uint##sm##_t min, uint##sm##_t max) { \ - uint##sm##_t x = uniform_u##sm(max - min); \ - return x + min; \ -} \ -int##sm##_t range_i##sm(int##sm##_t min, int##sm##_t max) { \ - return range_u##sm(min, max); \ -} \ cn_bits_u##sm* cn_gen_range_cn_bits_u##sm(cn_bits_u##sm* min, cn_bits_u##sm* max) { \ - return convert_to_cn_bits_u##sm(range_u##sm(min->val, max->val)); \ + return convert_to_cn_bits_u##sm(cn_gen_range_u##sm(min->val, max->val)); \ } \ cn_bits_i##sm* cn_gen_range_cn_bits_i##sm(cn_bits_i##sm* min, cn_bits_i##sm* max) { \ - return convert_to_cn_bits_i##sm(range_i##sm(min->val, max->val)); \ + return convert_to_cn_bits_i##sm(cn_gen_range_i##sm(min->val, max->val)); \ } RANGE_GEN(8); @@ -94,29 +32,17 @@ RANGE_GEN(32); RANGE_GEN(64); #define INEQ_GEN(sm)\ -uint##sm##_t lt_u##sm(uint##sm##_t max) { \ - return range_u##sm(0, max); \ -} \ -int##sm##_t lt_i##sm(int##sm##_t max) { \ - return range_i##sm(INT##sm##_MIN, max); \ -} \ cn_bits_u##sm* cn_gen_lt_cn_bits_u##sm(cn_bits_u##sm* max) { \ - return convert_to_cn_bits_u##sm(lt_u##sm(max->val)); \ + return convert_to_cn_bits_u##sm(cn_gen_lt_u##sm(max->val)); \ } \ cn_bits_i##sm* cn_gen_lt_cn_bits_i##sm(cn_bits_i##sm* max) { \ - return convert_to_cn_bits_i##sm(lt_i##sm(max->val)); \ -} \ -uint##sm##_t ge_u##sm(uint##sm##_t min) { \ - return range_u##sm(min, 0); \ -} \ -int##sm##_t ge_i##sm(int##sm##_t min) { \ - return range_i##sm(min, INT##sm##_MIN); \ + return convert_to_cn_bits_i##sm(cn_gen_lt_i##sm(max->val)); \ } \ cn_bits_u##sm* cn_gen_ge_cn_bits_u##sm(cn_bits_u##sm* min) { \ - return convert_to_cn_bits_u##sm(ge_u##sm(min->val)); \ + return convert_to_cn_bits_u##sm(cn_gen_ge_u##sm(min->val)); \ } \ cn_bits_i##sm* cn_gen_ge_cn_bits_i##sm(cn_bits_i##sm* min) { \ - return convert_to_cn_bits_i##sm(ge_i##sm(min->val)); \ + return convert_to_cn_bits_i##sm(cn_gen_ge_i##sm(min->val)); \ } INEQ_GEN(8); @@ -125,37 +51,21 @@ INEQ_GEN(32); INEQ_GEN(64); #define MULT_RANGE_GEN(sm) \ -uint##sm##_t mult_range_u##sm( \ - uint##sm##_t mul, \ - uint##sm##_t min, \ - uint##sm##_t max \ -) { \ - assert(mul != 0); \ - uint##sm##_t x = range_u##sm(min / mul, max / mul + (max % mul != 0)); \ - return x * mul; \ -} \ -int##sm##_t mult_range_i##sm( \ - int##sm##_t mul, \ - int##sm##_t min, \ - int##sm##_t max \ -) { \ - assert(mul != 0); \ - int##sm##_t x = range_i##sm(min / mul, max / mul + (max % mul != 0)); \ - return x * mul; \ -} \ cn_bits_u##sm* cn_gen_mult_range_cn_bits_u##sm( \ cn_bits_u##sm* mul, \ cn_bits_u##sm* min, \ cn_bits_u##sm* max \ ) { \ - return convert_to_cn_bits_u##sm(mult_range_u##sm(mul->val, min->val, max->val)); \ + return convert_to_cn_bits_u##sm( \ + cn_gen_mult_range_u##sm(mul->val, min->val, max->val)); \ } \ cn_bits_i##sm* cn_gen_mult_range_cn_bits_i##sm( \ cn_bits_i##sm* mul, \ cn_bits_i##sm* min, \ cn_bits_i##sm* max \ ) { \ - return convert_to_cn_bits_i##sm(mult_range_i##sm(mul->val, min->val, max->val)); \ + return convert_to_cn_bits_i##sm( \ + cn_gen_mult_range_i##sm(mul->val, min->val, max->val)); \ } MULT_RANGE_GEN(8); @@ -164,17 +74,11 @@ MULT_RANGE_GEN(32); MULT_RANGE_GEN(64); #define MULT_GEN(sm) \ -uint##sm##_t mult_u##sm(uint##sm##_t mul) { \ - return mult_range_u##sm(mul, 0, UINT##sm##_MAX); \ -} \ -int##sm##_t mult_i##sm(int##sm##_t mul) { \ - return mult_range_i##sm(mul, INT##sm##_MIN, INT##sm##_MAX); \ -}\ cn_bits_u##sm* cn_gen_mult_cn_bits_u##sm(cn_bits_u##sm* mul) { \ - return convert_to_cn_bits_u##sm(mult_u##sm(mul->val)); \ + return convert_to_cn_bits_u##sm(cn_gen_mult_u##sm(mul->val)); \ } \ cn_bits_i##sm* cn_gen_mult_cn_bits_i##sm(cn_bits_i##sm* mul) { \ - return convert_to_cn_bits_i##sm(mult_i##sm(mul->val)); \ + return convert_to_cn_bits_i##sm(cn_gen_mult_i##sm(mul->val)); \ } MULT_GEN(8); diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index fdc56cb05..2524271f0 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -35,7 +35,7 @@ for CONFIG in "${CONFIGS[@]}"; do echo "Running CI with CLI config \"$CONFIG\"" separator - FULL_CONFIG="$CONFIG --allowed-depth-failures=100 --input-timeout=1000 --progress-level=1" + FULL_CONFIG="$CONFIG --input-timeout=1000 --progress-level=1" # Test each `*.c` file for TEST in $FILES; do From 98e88ac78394b8d0000a6a779b6d7305e729713a Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 11 Dec 2024 19:44:36 +0000 Subject: [PATCH 105/148] CN: Fix CI The return code was not being propagated out of the main function correctly. This should signal error correctly now. --- tests/cn/duplicate_datatype_var.error.c.verify | 2 +- tests/cn/has_alloc_id_ptr_eq.error.c.verify | 3 +++ tests/cn/has_alloc_id_ptr_eq2.error.c.verify | 3 +++ tests/cn/unconstrained_ptr_eq.error.c.verify | 3 +++ tests/cn/unconstrained_ptr_eq2.error.c.verify | 3 +++ tests/diff-prog.py | 3 +-- 6 files changed, 14 insertions(+), 3 deletions(-) diff --git a/tests/cn/duplicate_datatype_var.error.c.verify b/tests/cn/duplicate_datatype_var.error.c.verify index 994b33506..70654f4b5 100644 --- a/tests/cn/duplicate_datatype_var.error.c.verify +++ b/tests/cn/duplicate_datatype_var.error.c.verify @@ -1,4 +1,4 @@ return code: 1 -tests/cn/duplicate_datatype_var.error.c:5:22: error: Re-using member name x within datatype definition. +tests/cn/duplicate_datatype_var.error.c:5:22: error: Re-using member name x within datatype definition (SMT limitation). Single { integer x } ^ diff --git a/tests/cn/has_alloc_id_ptr_eq.error.c.verify b/tests/cn/has_alloc_id_ptr_eq.error.c.verify index 38cb5eff8..75d9103df 100644 --- a/tests/cn/has_alloc_id_ptr_eq.error.c.verify +++ b/tests/cn/has_alloc_id_ptr_eq.error.c.verify @@ -1,4 +1,7 @@ return code: 1 +tests/cn/has_alloc_id_ptr_eq.error.c:10:12: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + return p == q; + ~~^~~~ [1/1]: f -- fail tests/cn/has_alloc_id_ptr_eq.error.c:10:5: error: Unprovable constraint return p == q; diff --git a/tests/cn/has_alloc_id_ptr_eq2.error.c.verify b/tests/cn/has_alloc_id_ptr_eq2.error.c.verify index 351dcefa7..70c6d12ac 100644 --- a/tests/cn/has_alloc_id_ptr_eq2.error.c.verify +++ b/tests/cn/has_alloc_id_ptr_eq2.error.c.verify @@ -1,4 +1,7 @@ return code: 1 +tests/cn/has_alloc_id_ptr_eq2.error.c:10:12: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + return p == q; + ~~^~~~ [1/1]: f -- fail tests/cn/has_alloc_id_ptr_eq2.error.c:10:5: error: Unprovable constraint return p == q; diff --git a/tests/cn/unconstrained_ptr_eq.error.c.verify b/tests/cn/unconstrained_ptr_eq.error.c.verify index b1f2c8c11..320ec8c2f 100644 --- a/tests/cn/unconstrained_ptr_eq.error.c.verify +++ b/tests/cn/unconstrained_ptr_eq.error.c.verify @@ -1,4 +1,7 @@ return code: 1 +tests/cn/unconstrained_ptr_eq.error.c:7:12: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + return p == q; + ~~^~~~ [1/1]: f -- fail tests/cn/unconstrained_ptr_eq.error.c:7:5: error: Unprovable constraint return p == q; diff --git a/tests/cn/unconstrained_ptr_eq2.error.c.verify b/tests/cn/unconstrained_ptr_eq2.error.c.verify index 810e8c0bb..ab1f62eab 100644 --- a/tests/cn/unconstrained_ptr_eq2.error.c.verify +++ b/tests/cn/unconstrained_ptr_eq2.error.c.verify @@ -1,4 +1,7 @@ return code: 1 +tests/cn/unconstrained_ptr_eq2.error.c:7:12: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + return p == q; + ~~^~~~ [1/1]: f -- fail tests/cn/unconstrained_ptr_eq2.error.c:7:5: error: Unprovable constraint return p == q; diff --git a/tests/diff-prog.py b/tests/diff-prog.py index d102521d9..99f47359d 100755 --- a/tests/diff-prog.py +++ b/tests/diff-prog.py @@ -106,5 +106,4 @@ def main(args): # parse args and call func (as set using set_defaults) args = parser.parse_args() -args.func(args) - +exit(args.func(args)) From 7a2f799bbb6d66dd65a868f97edcb9d5ce89a0c8 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Thu, 12 Dec 2024 13:33:46 +0000 Subject: [PATCH 106/148] Remove trailing whitespaces from lexer Also silence and ocamlformat warning --- backend/cn/lib/executable_spec_extract.ml | 4 +- parsers/c/c_lexer.mll | 50 +++++++++++------------ 2 files changed, 27 insertions(+), 27 deletions(-) diff --git a/backend/cn/lib/executable_spec_extract.ml b/backend/cn/lib/executable_spec_extract.ml index f038e56bc..2f904b3be 100644 --- a/backend/cn/lib/executable_spec_extract.ml +++ b/backend/cn/lib/executable_spec_extract.ml @@ -56,8 +56,8 @@ let sym_subst (s_replace, bt, s_with) = IT.make_subst [ (s_replace, IT.sym_ (s_with, bt, Cerb_location.unknown)) ] -(** -let concat2 (x : 'a list * 'b list) (y : 'a list * 'b list) : 'a list * 'b list = +(* + let concat2 (x : 'a list * 'b list) (y : 'a list * 'b list) : 'a list * 'b list = let a1, b1 = x in let a2, b2 = y in (a1 @ a2, b1 @ b2) diff --git a/parsers/c/c_lexer.mll b/parsers/c/c_lexer.mll index 173485bb1..9ca05fc86 100644 --- a/parsers/c/c_lexer.mll +++ b/parsers/c/c_lexer.mll @@ -93,14 +93,14 @@ let lexicon: (string, token) Hashtbl.t = (* BEGIN CN *) -type kw_kind = - | Production - | Experimental - | Unimplemented +type kw_kind = + | Production + | Experimental + | Unimplemented let cn_keywords: (string * (kw_kind * Tokens.token)) list = [ (* CN 'production' keywords: well-supported and suitable for general use *) - "good" , (Production, CN_GOOD); + "good" , (Production, CN_GOOD); "boolean" , (Production, CN_BOOL); "integer" , (Production, CN_INTEGER); "u8" , (Production, CN_BITS (`U,8)); @@ -150,7 +150,7 @@ let cn_keywords: (string * (kw_kind * Tokens.token)) list = [ (* CN 'experimental' keywords - functional in some cases but not recommended for general use *) - "cn_list" , (Experimental, CN_LIST); + "cn_list" , (Experimental, CN_LIST); "cn_tuple" , (Experimental, CN_TUPLE); "cn_set" , (Experimental, CN_SET); "cn_have" , (Experimental, CN_HAVE); @@ -164,28 +164,28 @@ let cn_keywords: (string * (kw_kind * Tokens.token)) list = [ "unpack" , (Unimplemented, CN_UNPACK); ] -let cn_kw_table = +let cn_kw_table = let kw_table = Hashtbl.create 0 in - List.iter (fun (key, builder) -> Hashtbl.add kw_table key builder) cn_keywords; - kw_table + List.iter (fun (key, builder) -> Hashtbl.add kw_table key builder) cn_keywords; + kw_table -(* Attempt to lex a CN keyword. These may be: +(* Attempt to lex a CN keyword. These may be: * 'production' - well-supported and suitable for general use - * 'experimental' - functional in some cases but not recommended for general use - * 'unimplemented' - non-functional, but the keyword is reserved + * 'experimental' - functional in some cases but not recommended for general use + * 'unimplemented' - non-functional, but the keyword is reserved May raise `Not_found`, indicating `id` is not a recognized CN keyword. *) -let cn_lex_keyword id start_pos end_pos = +let cn_lex_keyword id start_pos end_pos = (* Try to lex CN production keywords *) - match Hashtbl.find cn_kw_table id with - | (Production, kw) -> kw - | (Experimental, kw) -> - prerr_endline + match Hashtbl.find cn_kw_table id with + | (Production, kw) -> kw + | (Experimental, kw) -> + prerr_endline (Pp_errors.make_message Cerb_location.(region (start_pos, end_pos) NoCursor) Errors.(CPARSER (Errors.Cparser_experimental_keyword id)) Warning); - kw + kw | (Unimplemented, _) -> raise (Error (Errors.Cparser_unimplemented_keyword id)) (* END CN *) @@ -588,10 +588,10 @@ and initial flags = parse | ['A'-'Z']['0'-'9' 'A'-'Z' 'a'-'z' '_']* as id { if flags.inside_cn then - try - cn_lex_keyword id lexbuf.lex_start_p lexbuf.lex_curr_p + try + cn_lex_keyword id lexbuf.lex_start_p lexbuf.lex_curr_p with Not_found -> - UNAME id + UNAME id else UNAME id } @@ -601,10 +601,10 @@ and initial flags = parse Hashtbl.find lexicon id with Not_found -> if flags.inside_cn then - try - cn_lex_keyword id lexbuf.lex_start_p lexbuf.lex_curr_p + try + cn_lex_keyword id lexbuf.lex_start_p lexbuf.lex_curr_p with Not_found -> - LNAME id + LNAME id else LNAME id } @@ -627,7 +627,7 @@ let create_lexer ~(inside_cn:bool) : [ `LEXER of lexbuf -> token ] = match !lexer_state with | LSRegular -> let at_magic_comments = Switches.(has_switch SW_at_magic_comments) in - let magic_comment_char = + let magic_comment_char = if Switches.(has_switch SW_magic_comment_char_dollar) then '$' else '@' From 940e91f9e753acc0116d8157371beea39840ba83 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Thu, 12 Dec 2024 14:32:41 +0000 Subject: [PATCH 107/148] CN: Reduce warnings for experimental tokens Fixes #574 This shares state implicitly across different lexers, even with `create_lexer`. Threading this state in and out of the lexer is ugly. And we would probably want warnings once per invocation anyway. --- parsers/c/c_lexer.mll | 31 ++++++++++++++----- tests/cn/to_from_bytes_owned.c.verify | 6 ---- .../pointer_copy_memcpy.pass.c.no_annot | 6 ---- ...r_dataflow_direct_bytewise.pass.c.no_annot | 6 ---- ...from_int_disambiguation_1.annot.c.no_annot | 6 ---- ...om_int_disambiguation_1.annot.c.with_annot | 6 ---- ..._from_int_disambiguation_2.pass.c.no_annot | 6 ---- ...from_int_disambiguation_3.error.c.no_annot | 6 ---- ...om_int_disambiguation_3.error.c.with_annot | 6 ---- ...m_int_subtraction_auto_xy.annot.c.no_annot | 6 ---- ...int_subtraction_auto_xy.annot.c.with_annot | 6 ---- ...m_int_subtraction_auto_yx.annot.c.no_annot | 6 ---- ...int_subtraction_auto_yx.annot.c.with_annot | 6 ---- ...int_subtraction_global_xy.annot.c.no_annot | 6 ---- ...t_subtraction_global_xy.annot.c.with_annot | 6 ---- ...int_subtraction_global_yx.annot.c.no_annot | 6 ---- ...t_subtraction_global_yx.annot.c.with_annot | 6 ---- ...m_ptr_subtraction_auto_xy.error.c.no_annot | 6 ---- ...m_ptr_subtraction_auto_yx.error.c.no_annot | 6 ---- ...ptr_subtraction_global_xy.error.c.no_annot | 6 ---- ...ptr_subtraction_global_yx.error.c.no_annot | 6 ---- .../provenance_basic_auto_yx.error.c.no_annot | 6 ---- ...rovenance_basic_global_yx.error.c.no_annot | 6 ---- ...c_using_uintptr_t_auto_yx.annot.c.no_annot | 6 ---- ...using_uintptr_t_auto_yx.annot.c.with_annot | 6 ---- ...using_uintptr_t_global_yx.annot.c.no_annot | 6 ---- ...ing_uintptr_t_global_yx.annot.c.with_annot | 6 ---- .../provenance_lost_escape_1.annot.c.no_annot | 6 ---- ...rovenance_lost_escape_1.annot.c.with_annot | 6 ---- 29 files changed, 24 insertions(+), 175 deletions(-) diff --git a/parsers/c/c_lexer.mll b/parsers/c/c_lexer.mll index 9ca05fc86..eac9a3e82 100644 --- a/parsers/c/c_lexer.mll +++ b/parsers/c/c_lexer.mll @@ -93,12 +93,12 @@ let lexicon: (string, token) Hashtbl.t = (* BEGIN CN *) -type kw_kind = +type cn_keyword_kind = | Production | Experimental | Unimplemented -let cn_keywords: (string * (kw_kind * Tokens.token)) list = [ +let cn_keywords: (string * (cn_keyword_kind * Tokens.token)) list = [ (* CN 'production' keywords: well-supported and suitable for general use *) "good" , (Production, CN_GOOD); "boolean" , (Production, CN_BOOL); @@ -164,10 +164,25 @@ let cn_keywords: (string * (kw_kind * Tokens.token)) list = [ "unpack" , (Unimplemented, CN_UNPACK); ] -let cn_kw_table = - let kw_table = Hashtbl.create 0 in - List.iter (fun (key, builder) -> Hashtbl.add kw_table key builder) cn_keywords; - kw_table + +(* This table is mutated during lexing to reduce the number of warnings + for experimental features. Unfortunately, this makes it so that the + behaviour of the lexer implicitly changes across multiple calls + to [create_lexer]. + + In some sense, this is fine, since Cerberus/CN only processes one + translation unit per invocation from the command line, and we would + likely want warnings to only occur once per invocation. + + However, if this were to change, and especially if this were to be + made concurrent, this would need to be revisited. + + It is possible to thread the seen experimental tokens back to the caller for + them to decide; it is also ugly. *) +let cn_keywords = + let table = Hashtbl.create 0 in + List.iter (fun (key, builder) -> Hashtbl.add table key builder) cn_keywords; + table (* Attempt to lex a CN keyword. These may be: * 'production' - well-supported and suitable for general use @@ -177,9 +192,11 @@ let cn_kw_table = May raise `Not_found`, indicating `id` is not a recognized CN keyword. *) let cn_lex_keyword id start_pos end_pos = (* Try to lex CN production keywords *) - match Hashtbl.find cn_kw_table id with + match Hashtbl.find cn_keywords id with | (Production, kw) -> kw | (Experimental, kw) -> + (* Only want to warn once _per CN/Cerberus invocation_ *) + Hashtbl.replace cn_keywords id (Production, kw); prerr_endline (Pp_errors.make_message Cerb_location.(region (start_pos, end_pos) NoCursor) diff --git a/tests/cn/to_from_bytes_owned.c.verify b/tests/cn/to_from_bytes_owned.c.verify index 862824933..3e6df251b 100644 --- a/tests/cn/to_from_bytes_owned.c.verify +++ b/tests/cn/to_from_bytes_owned.c.verify @@ -5,10 +5,4 @@ tests/cn/to_from_bytes_owned.c:5:9: warning: experimental keyword 'to_bytes' (us tests/cn/to_from_bytes_owned.c:9:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*@ from_bytes Owned(p); @*/ ^~~~~~~~~~ -tests/cn/to_from_bytes_owned.c:11:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*@ to_bytes Owned(p); @*/ - ^~~~~~~~ -tests/cn/to_from_bytes_owned.c:12:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*@ from_bytes Owned(p); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot index 8ca1980fa..5d721c18c 100644 --- a/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:11:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Block(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:14:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot index 19236f25e..3318d1b36 100644 --- a/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot @@ -5,14 +5,8 @@ tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:28:5: w tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:48:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:49:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Block(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:52:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&q); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:53:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&p); @*/ - ^~~~~~~~~~ [1/2]: user_memcpy -- pass [2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot index 337c08e78..1f3727260 100644 --- a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:30:5: error: Missing resource for writing *r=11; // is this free of UB? diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot index 210e61dec..b9ac428bf 100644 --- a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot index 4bfc43d8c..f95afd65a 100644 --- a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot index e4d756067..307b850cb 100644 --- a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:34:5: error: Missing resource for writing *r=11; // CN VIP UB if ¬ANNOT diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot index d71c5d52d..7e92c5252 100644 --- a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:20:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:35:7: error: `©_alloc_id((u64)&&x[1'u64], copy_alloc_id((u64)value, &y))[(u64)(0'i32 - 1'i32)]` out of bounds r=r-1; // CN VIP UB if NO_ROUND TRIP && ANNOT diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot index b61714190..b74bc7642 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:22:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:25:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:33:5: error: Missing resource for writing *p = 11; // CN VIP UB (no annot) diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot index 0069b3ddb..01b36b274 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:22:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:25:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot index cc475aa53..6d353cb30 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:22:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:25:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:33:5: error: Missing resource for writing *p = 11; // CN VIP UB (no annot) diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot index dae5361dd..f9fccfe70 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:22:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:25:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot index b42a4d87e..1eef026b8 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:35:5: error: Missing resource for writing *p = 11; // CN VIP UB (no annot) diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot index 2422839bd..d9eed5cb3 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot index e4b98e8fb..be53d1282 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:35:5: error: Missing resource for writing *p = 11; // CN VIP UB (no annot) diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot index f3cafd1e4..cb7c78a16 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot index 70bdfc0ec..d5d92a478 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&r); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:13:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&r); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:16:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:10:22: error: Undefined behaviour ptrdiff_t offset = q - p; // CN VIP UB diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot index 97031e53f..be6bfec79 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&r); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:13:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&r); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:16:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:10:22: error: Undefined behaviour ptrdiff_t offset = q - p; // CN VIP UB diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot index bf6314401..2f890559f 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:14:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&r); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:15:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:17:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&r); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:18:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:12:22: error: Undefined behaviour ptrdiff_t offset = q - p; // CN VIP UB diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot index 247144502..71fe73593 100644 --- a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:14:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&r); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:15:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:17:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&r); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:18:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:12:22: error: Undefined behaviour ptrdiff_t offset = q - p; // CN VIP UB diff --git a/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot index e8a3c93c2..a61e8f86b 100644 --- a/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot +++ b/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:10:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:11:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:13:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:14:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:19:5: error: Missing resource for writing *p = 11; // CN VIP UB diff --git a/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot index 52770dbba..432786655 100644 --- a/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot +++ b/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:13:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:16:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:21:5: error: Missing resource for writing *p = 11; // CN_VIP UB diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot index 178474641..d7febc047 100644 --- a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:26:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:29:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:37:5: error: Missing resource for writing *p = 11; // CN VIP UB (no annot) diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot index 88342e382..0b7385b05 100644 --- a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:26:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:29:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot index 06e768c20..38bfded08 100644 --- a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:26:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:29:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:37:5: error: Missing resource for writing *p = 11; // CN VIP UB (no annot) diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot index 1eb84e572..e58d8f578 100644 --- a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&p); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:26:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&q); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&p); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:29:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&q); @*/ - ^~~~~~~~~~ [1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot index fe54164b4..8af82288f 100644 --- a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot +++ b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot @@ -2,15 +2,9 @@ return code: 1 tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&i1); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&i4); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&i1); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&i4); @*/ - ^~~~~~~~~~ [1/1]: main -- fail tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:30:5: error: Missing resource for writing *q = 11; // CN VIP UB (no annot) diff --git a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot index d59619ffb..5ef6dc102 100644 --- a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot +++ b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot @@ -2,13 +2,7 @@ return code: 0 tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ to_bytes Owned(&i1); @*/ ^~~~~~~~ -tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ to_bytes Owned(&i4); @*/ - ^~~~~~~~ tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) /*CN_VIP*//*@ from_bytes Owned(&i1); @*/ ^~~~~~~~~~ -tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) - /*CN_VIP*//*@ from_bytes Owned(&i4); @*/ - ^~~~~~~~~~ [1/1]: main -- pass From 681e9973ccc1f9dfc89b7a980f41802f7baea2c3 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 11 Dec 2024 10:46:28 +0000 Subject: [PATCH 108/148] CN VIP: Correct/explain shifting assumptions --- backend/cn/bin/main.ml | 4 + backend/cn/lib/check.ml | 178 ++++++++++++--------------- backend/cn/lib/core_to_mucore.ml | 7 +- backend/cn/lib/resourceInference.ml | 4 +- backend/cn/lib/resourceInference.mli | 6 +- backend/cn/lib/typeErrors.ml | 20 ++- frontend/model/translation.lem | 2 +- 7 files changed, 106 insertions(+), 115 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index fc19e0845..f9b9fd508 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -59,6 +59,10 @@ let frontend ~macros ~incl_dirs ~incl_files astprints ~filename ~magic_comment_c Ocaml_implementation.set Ocaml_implementation.HafniumImpl.impl; Switches.set ([ "inner_arg_temps"; "at_magic_comments" ] + (* TODO (DCM, VIP) figure out how to support liveness checks for read-only + resources and then switch on "strict_pointer_arith" to elaborate array + shift to the effectful version. "strict_pointer_relationals" is also + assumed, but this does not affect elaboration. *) @ if magic_comment_char_dollar then [ "magic_comment_char_dollar" ] else []); let@ stdlib = load_core_stdlib () in let@ impl = load_core_impl stdlib impl_name in diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index eaf3ea11a..ccbba1430 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -431,25 +431,14 @@ let check_has_alloc_id loc ptr ub_unspec = return () -let check_alloc_bounds loc ~ptr ub_unspec = - if !use_vip then ( - let here = Locations.other __FUNCTION__ in - let module H = Alloc.History in - let H.{ base; size } = H.(split (lookup_ptr ptr here) here) in - let addr = addr_ ptr here in - let lower = le_ (base, addr) here in - let upper = le_ (addr, add_ (base, size) here) here in - let constr = and_ [ lower; upper ] here in - let@ provable = provable loc in - match provable @@ LC.T constr with - | `True -> return () - | `False -> - let@ model = model () in - let ub = CF.Undefined.(UB_CERB004_unspecified ub_unspec) in - fail (fun ctxt -> - { loc; msg = Alloc_out_of_bounds { constr; term = ptr; ub; ctxt; model } })) - else - return () +let in_bounds ptr = + let here = Locations.other __FUNCTION__ in + let module H = Alloc.History in + let H.{ base; size } = H.(split (lookup_ptr ptr here) here) in + let addr = addr_ ptr here in + let lower = le_ (base, addr) here in + let upper = le_ (addr, add_ (base, size) here) here in + [ lower; upper ] let check_both_eq_alloc loc arg1 arg2 ub = @@ -470,19 +459,25 @@ let check_both_eq_alloc loc arg1 arg2 ub = | `True -> return () -let check_live_alloc_bounds reason loc arg ub term constr = - let@ base_size = RI.Special.get_live_alloc reason loc arg in - let here = Locations.other __FUNCTION__ in - let Alloc.History.{ base; size } = Alloc.History.split base_size here in - if !use_vip then ( - let constr = constr ~base ~size in +(** If [ptrs] has more than one element, the allocation IDs must be equal *) +let check_live_alloc_bounds ?(skip_live = false) reason loc ub ptrs = + if !use_vip then + let@ () = + if skip_live then + return () + else + RI.Special.check_live_alloc reason loc (List.hd ptrs) + in + let here = Locations.other __FUNCTION__ in + let constr = and_ (List.concat_map in_bounds ptrs) here in let@ provable = provable loc in match provable @@ LC.T constr with | `True -> return () | `False -> let@ model = model () in fail (fun ctxt -> - { loc; msg = Alloc_out_of_bounds { term; constr; ub; ctxt; model } })) + let term = if List.length ptrs = 1 then List.hd ptrs else IT.tuple_ ptrs here in + { loc; msg = Alloc_out_of_bounds { constr; term; ub; ctxt; model } }) else return () @@ -585,23 +580,34 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> + (* NOTE: This case should not be present - only PtrArrayShift. The issue + is that the elaboration of create_rdonly uses PtrArrayShift, but right + now we don't have fractional resources to prove that such objects are + live. Might be worth considering a read-only resource as a stop-gap. + But for now, I just skip the liveness check. *) + let unspec = CF.Undefined.UB_unspec_pointer_add in + let@ () = check_has_alloc_id loc vt1 unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in let result = arrayShift_ ~base:vt1 ct ~index:(cast_ Memory.uintptr_bt vt2 loc) loc in - let unspec = CF.Undefined.UB_unspec_pointer_add in - let@ () = check_has_alloc_id loc vt1 unspec in - let@ () = check_alloc_bounds loc ~ptr:result unspec in + let@ () = + check_live_alloc_bounds ~skip_live:true `ISO_array_shift loc ub [ result ] + in k result)) | PEmember_shift (pe, tag, member) -> let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun vt -> let@ _ = get_struct_member_type loc tag member in - let result = memberShift_ (vt, tag, member) loc in - let@ () = check_has_alloc_id loc vt CF.Undefined.UB_unspec_pointer_add in + (* This should only be called after a PtrValidForDeref, so if we were + willing to optimise, we could skip the has_alloc_id, bounds and + liveness checks. *) let unspec = CF.Undefined.UB_unspec_pointer_add in let@ () = check_has_alloc_id loc vt unspec in - let@ () = check_alloc_bounds loc ~ptr:result unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in + let result = memberShift_ (vt, tag, member) loc in + let@ () = check_live_alloc_bounds `ISO_member_shift loc ub [ result ] in k result) | PEnot pe -> let@ () = WellTyped.ensure_base_type loc ~expect Bool in @@ -1378,15 +1384,6 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = here) *))) in - let both_in_bounds ~base ~size arg1 arg2 = - let addr1, addr2 = (addr_ arg1 here, addr_ arg2 here) in - let lower1, lower2 = (le_ (base, addr1) here, le_ (base, addr2) here) in - let upper1, upper2 = - ( le_ (addr1, add_ (base, size) here) here, - le_ (addr2, add_ (base, size) here) here ) - in - and_ [ lower1; lower2; upper1; upper2 ] here - in let pointer_op op pe1 pe2 = let ub = CF.Undefined.UB053_distinct_aggregate_union_pointer_comparison in let@ () = ensure_base_type loc ~expect Bool in @@ -1395,15 +1392,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> let@ () = check_both_eq_alloc loc arg1 arg2 ub in - let@ () = - check_live_alloc_bounds - `Ptr_cmp - loc - arg1 - ub - (IT.tuple_ [ arg1; arg2 ] here) - (both_in_bounds arg1 arg2) - in + let@ () = check_live_alloc_bounds `Ptr_cmp loc ub [ arg1; arg2 ] in k (op (arg1, arg2)))) in (match memop with @@ -1430,17 +1419,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = check_both_eq_alloc loc arg1 arg2 ub in let ub_unspec = CF.Undefined.UB_unspec_pointer_sub in let ub = CF.Undefined.(UB_CERB004_unspecified ub_unspec) in - let@ () = - check_live_alloc_bounds - `Ptr_diff - loc - arg1 - ub - (IT.tuple_ [ arg1; arg2 ] here) - (both_in_bounds arg1 arg2) - in let ptr_diff_bt = Memory.bt_of_sct (Integer Ptrdiff_t) in - let value = + let@ () = check_live_alloc_bounds `Ptr_diff loc ub [ arg1; arg2 ] in + let result = (* TODO: confirm that the cast from uintptr_t to ptrdiff_t yields the expected result, or signal UB050_pointers_subtraction_not_representable *) @@ -1449,7 +1430,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = int_lit_ divisor ptr_diff_bt loc ) loc in - k value)) + k result)) | IntFromPtr (act_from, act_to, pe) -> let@ () = WellTyped.WCT.is_ct act_from.loc act_from.ct in let@ () = WellTyped.WCT.is_ct act_to.loc act_to.ct in @@ -1509,18 +1490,27 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = WellTyped.WCT.is_ct act.loc act.ct in let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in - (* TODO (DCM, VIP): check. Also: this is the same as PtrWellAligned *) + (* TODO (DCM, VIP): error if called on Void or Function Ctype. + return false if resource missing *) check_pexpr pe (fun arg -> - let value = aligned_ (arg, act.ct) loc in - k value) + (* let unspec = CF.Undefined.UB_unspec_pointer_add in *) + (* let@ () = check_has_alloc_id loc arg unspec in *) + (* let index = num_lit_ Z.one Memory.uintptr_bt here in *) + (* let check_this = arrayShift_ ~base:arg ~index act.ct loc in *) + (* let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in *) + (* let@ () = check_live_alloc_bounds `ISO_array_shift loc ub [ check_this ] in *) + let result = aligned_ (arg, act.ct) loc in + k result) | PtrWellAligned (act, pe) -> let@ () = WellTyped.WCT.is_ct act.loc act.ct in let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in - (* TODO (DCM, VIP) check *) + (* TODO (DCM, VIP): error if called on Void or Function Ctype *) check_pexpr pe (fun arg -> - let value = aligned_ (arg, act.ct) loc in - k value) + (* let unspec = CF.Undefined.UB_unspec_pointer_add in *) + (* let@ () = check_has_alloc_id loc arg unspec in *) + let result = aligned_ (arg, act.ct) loc in + k result) | PtrArrayShift (pe1, act, pe2) -> let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in @@ -1528,31 +1518,18 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> + let unspec = CF.Undefined.UB_unspec_pointer_add in + let@ () = check_has_alloc_id loc vt1 unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in let result = arrayShift_ ~base:vt1 ~index:(cast_ Memory.uintptr_bt vt2 loc) act.ct loc in - let ub_unspec = CF.Undefined.UB_unspec_pointer_add in - let ub = CF.Undefined.(UB_CERB004_unspecified ub_unspec) in - let@ () = check_has_alloc_id loc vt1 ub_unspec in - let here = Locations.other __FUNCTION__ in - let@ () = - check_live_alloc_bounds - `ISO_array_shift - loc - vt1 - ub - result - (fun ~base ~size -> - let addr = addr_ result here in - let lower = le_ (base, addr) here in - let upper = le_ (addr, add_ (base, size) here) here in - and_ [ lower; upper ] here) - in + let@ () = check_live_alloc_bounds `ISO_array_shift loc ub [ result ] in k result)) - | PtrMemberShift (_tag_sym, _memb_ident, _pe) -> - (* FIXME(CHERI merge) *) - (* there is now an effectful variant of the member shift operator (which is UB when creating an out of bound pointer) *) - Cerb_debug.error "todo: PtrMemberShift" + | PtrMemberShift _ -> + unsupported + (Loc.other __FUNCTION__) + !^"PtrMemberShift should be a CHERI only construct" | CopyAllocId (pe1, pe2) -> let@ () = WellTyped.ensure_base_type loc ~expect:Memory.uintptr_bt (Mu.bt_of_pexpr pe1) @@ -1562,22 +1539,17 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> + let unspec = CF.Undefined.UB_unspec_copy_alloc_id in + let@ () = check_has_alloc_id loc vt2 unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in let result = copyAllocId_ ~addr:vt1 ~loc:vt2 loc in - let ub_unspec = CF.Undefined.UB_unspec_copy_alloc_id in - let@ () = check_has_alloc_id loc vt2 ub_unspec in - let ub = CF.Undefined.(UB_CERB004_unspecified ub_unspec) in - let@ () = - check_live_alloc_bounds `Copy_alloc_id loc vt2 ub vt1 (fun ~base ~size -> - let addr = vt1 in - let lower = le_ (base, addr) here in - let upper = le_ (addr, add_ (base, size) here) here in - and_ [ lower; upper ] here) - in + let@ () = check_live_alloc_bounds `Copy_alloc_id loc ub [ result ] in k result)) | Memcpy _ -> (* should have been intercepted by memcpy_proxy *) assert false - | Memcmp _ (* (asym 'bty * asym 'bty * asym 'bty) *) -> + | Memcmp _ -> + (* TODO (DCM, VIP) *) Cerb_debug.error "todo: Memcmp" | Realloc _ (* (asym 'bty * asym 'bty * asym 'bty) *) -> Cerb_debug.error "todo: Realloc" @@ -1632,8 +1604,12 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k ret) | CreateReadOnly (_sym1, _ct, _sym2, _prefix) -> Cerb_debug.error "todo: CreateReadOnly" - | Alloc (_ct, _sym, _prefix) -> Cerb_debug.error "todo: Alloc" - | Kill (Dynamic, _asym) -> Cerb_debug.error "todo: Free" + | Alloc (_ct, _sym, _prefix) -> + (* TODO (DCM, VIP) *) + Cerb_debug.error "todo: Alloc" + | Kill (Dynamic, _asym) -> + (* TODO (DCM, VIP) *) + Cerb_debug.error "todo: Free" | Kill (Static ct, pe) -> let@ () = WellTyped.WCT.is_ct loc ct in let@ () = WellTyped.ensure_base_type loc ~expect Unit in diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index b82179a2b..7bca6a7e2 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -233,7 +233,7 @@ let rec n_pexpr ~inherit_loc loc (Pexpr (annots, bty, pe)) : unit Mucore.pexpr = | PEmemop (_mop, _pes) -> (* FIXME(CHERI merge) *) (* this construct is currently only used by the CHERI switch *) - assert_error loc !^"PEmemop" + assert_error loc !^"PEmemop (CHERI only)" | PEnot e' -> let e' = n_pexpr loc e' in annotate (PEnot e') @@ -626,9 +626,12 @@ let n_memop ~inherit_loc loc memop pexprs = let pe1 = n_pexpr loc pe1 in let pe2 = n_pexpr loc pe2 in CopyAllocId (pe1, pe2) + | PtrMemberShift _, _ -> assert_error loc !^"PtrMemberShift (CHERI only)" | memop, pexprs1 -> let err = - !^(show_n_memop memop) + !^__FUNCTION__ + ^^ colon + ^^^ !^(show_n_memop memop) ^^^ !^"applied to" ^^^ int (List.length pexprs1) ^^^ !^"arguments" diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 706182772..eaa4262a4 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -484,7 +484,7 @@ module Special = struct (** This function checks whether [ptr1] belongs to a live allocation. It searches the context (without modification) for either an Alloc(p) or an Owned(p) such that (alloc_id) p == (alloc_id) ptr. *) - let get_live_alloc reason loc ptr = + let check_live_alloc reason loc ptr = let module Ans = struct type t = | Found @@ -523,7 +523,7 @@ module Special = struct let@ found, _ = map_and_fold_resources loc f (return Ans.No_res) in let@ found in match found with - | Ans.Found -> return (Alloc.History.lookup_ptr ptr here) + | Ans.Found -> return () | No_res -> fail (fun ctxt -> let msg = diff --git a/backend/cn/lib/resourceInference.mli b/backend/cn/lib/resourceInference.mli index 785b2f305..016e2243e 100644 --- a/backend/cn/lib/resourceInference.mli +++ b/backend/cn/lib/resourceInference.mli @@ -18,11 +18,11 @@ module General : sig end module Special : sig - val get_live_alloc - : [ `Copy_alloc_id | `Ptr_cmp | `Ptr_diff | `ISO_array_shift ] -> + val check_live_alloc + : [ `Copy_alloc_id | `Ptr_cmp | `Ptr_diff | `ISO_array_shift | `ISO_member_shift ] -> Locations.t -> IndexTerms.t -> - IndexTerms.t Typing.m + unit Typing.m val predicate_request : Locations.t -> diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index ffaf02ef1..bb5fd5454 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -211,7 +211,8 @@ type message = model : Solver.model_with_q } | Allocation_not_live of - { reason : [ `Copy_alloc_id | `Ptr_cmp | `Ptr_diff | `ISO_array_shift ]; + { reason : + [ `Copy_alloc_id | `Ptr_cmp | `Ptr_diff | `ISO_array_shift | `ISO_member_shift ]; ptr : IT.t; ctxt : Context.t * log; model_constr : (Solver.model_with_q * IT.t) option @@ -519,12 +520,19 @@ let pp_message te = in { short; descr = Some descr; state = Some state } | Allocation_not_live { reason; ptr; ctxt; model_constr } -> - let reason = + let adjust = function + | IT.IT (CopyAllocId { loc; _ }, _, _) -> loc + | IT.IT (ArrayShift { base; _ }, _, _) -> base + | IT.IT (MemberShift (ptr, _, _), _, _) -> ptr + | _ -> assert false + in + let reason, ptr = match reason with - | `Copy_alloc_id -> "copy_alloc_id" - | `Ptr_diff -> "pointer difference" - | `Ptr_cmp -> "pointer comparison" - | `ISO_array_shift -> "array shift" + | `Copy_alloc_id -> ("copy_alloc_id", adjust ptr) + | `Ptr_diff -> ("pointer difference", ptr) + | `Ptr_cmp -> ("pointer comparison", ptr) + | `ISO_array_shift -> ("array shift", adjust ptr) + | `ISO_member_shift -> ("member shift", adjust ptr) in let short = !^"Pointer " ^^ bquotes (IT.pp ptr) ^^^ !^"needs to be live for" ^^^ !^reason diff --git a/frontend/model/translation.lem b/frontend/model/translation.lem index 3d2ad19e0..05c1b1e6b 100644 --- a/frontend/model/translation.lem +++ b/frontend/model/translation.lem @@ -2819,7 +2819,7 @@ end E.return begin C.Expr [Annot.Astd "§6.5.2.3#3, sentence 2"] ( C.Esseq e_wrp.E.sym_pat core_e ( -begin if Global.has_strict_pointer_arith () || Global.is_CHERI () (* || Global.is_PNVI () *) then +begin if Global.is_CHERI () then (Caux.mk_memop_e (Mem_common.PtrMemberShift tag_sym ident) [e_wrp.E.sym_pe]) else Caux.mk_pure_e (Caux.mk_member_shift_pe e_wrp.E.sym_pe tag_sym ident) From b5f552e65e6b076c0a43f4a69df14b9931cd4a34 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Mon, 16 Dec 2024 16:09:22 +0000 Subject: [PATCH 109/148] CN VIP: optimise shifts For some reason, checking the resource context is faster than doing a bounds check. Since having an Owned in the context is sufficient (but not necessary) to proving a pointer is in bounds, and often a pointer will be constructed just before it is dereferenced, then it suffices to check the context for the exact pointer as a common case, and fall back to the slow path for the rest. --- backend/cn/lib/check.ml | 56 +++++++++++++++++++--------- backend/cn/lib/resourceInference.ml | 9 +++-- backend/cn/lib/resourceInference.mli | 6 +++ 3 files changed, 50 insertions(+), 21 deletions(-) diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index ccbba1430..aaa448c41 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -482,6 +482,13 @@ let check_live_alloc_bounds ?(skip_live = false) reason loc ub ptrs = return () +let valid_for_deref loc pointer ct = + RI.Special.has_predicate + loc + (Access Deref) + ({ name = Owned (ct, Uninit); pointer; iargs = [] }, None) + + let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let orig_pe = pe in let (Mu.Pexpr (loc, _, expect, pe_)) = pe in @@ -585,29 +592,38 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = now we don't have fractional resources to prove that such objects are live. Might be worth considering a read-only resource as a stop-gap. But for now, I just skip the liveness check. *) - let unspec = CF.Undefined.UB_unspec_pointer_add in - let@ () = check_has_alloc_id loc vt1 unspec in - let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in let result = arrayShift_ ~base:vt1 ct ~index:(cast_ Memory.uintptr_bt vt2 loc) loc in + let@ has_owned = valid_for_deref loc result ct in let@ () = - check_live_alloc_bounds ~skip_live:true `ISO_array_shift loc ub [ result ] + if has_owned then + return () + else ( + let unspec = CF.Undefined.UB_unspec_pointer_add in + let@ () = check_has_alloc_id loc vt1 unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in + check_live_alloc_bounds ~skip_live:true `ISO_array_shift loc ub [ result ]) in k result)) | PEmember_shift (pe, tag, member) -> let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun vt -> - let@ _ = get_struct_member_type loc tag member in - (* This should only be called after a PtrValidForDeref, so if we were - willing to optimise, we could skip the has_alloc_id, bounds and - liveness checks. *) - let unspec = CF.Undefined.UB_unspec_pointer_add in - let@ () = check_has_alloc_id loc vt unspec in - let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in + let@ ct = get_struct_member_type loc tag member in let result = memberShift_ (vt, tag, member) loc in - let@ () = check_live_alloc_bounds `ISO_member_shift loc ub [ result ] in + (* This should only be called after a PtrValidForDeref, so if we + were willing to optimise, we could skip to [k result]. *) + let@ has_owned = valid_for_deref loc result ct in + let@ () = + if has_owned then + return () + else ( + let unspec = CF.Undefined.UB_unspec_pointer_add in + let@ () = check_has_alloc_id loc vt unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in + check_live_alloc_bounds `ISO_member_shift loc ub [ result ]) + in k result) | PEnot pe -> let@ () = WellTyped.ensure_base_type loc ~expect Bool in @@ -1518,13 +1534,19 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> - let unspec = CF.Undefined.UB_unspec_pointer_add in - let@ () = check_has_alloc_id loc vt1 unspec in - let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in let result = - arrayShift_ ~base:vt1 ~index:(cast_ Memory.uintptr_bt vt2 loc) act.ct loc + arrayShift_ ~base:vt1 act.ct ~index:(cast_ Memory.uintptr_bt vt2 loc) loc + in + let@ has_owned = valid_for_deref loc result act.ct in + let@ () = + if has_owned then + k result + else ( + let unspec = CF.Undefined.UB_unspec_pointer_add in + let@ () = check_has_alloc_id loc vt1 unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in + check_live_alloc_bounds `ISO_array_shift loc ub [ result ]) in - let@ () = check_live_alloc_bounds `ISO_array_shift loc ub [ result ] in k result)) | PtrMemberShift _ -> unsupported diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index eaa4262a4..78954fce6 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -481,6 +481,11 @@ module Special = struct match result with Some r -> return r | None -> fail_missing_resource loc uiinfo + let has_predicate loc situation (request, oinfo) = + let@ result = sandbox @@ predicate_request loc situation (request, oinfo) in + return (Result.is_ok result) + + (** This function checks whether [ptr1] belongs to a live allocation. It searches the context (without modification) for either an Alloc(p) or an Owned(p) such that (alloc_id) p == (alloc_id) ptr. *) @@ -539,10 +544,6 @@ module Special = struct { loc; msg }) - let predicate_request loc situation (request, oinfo) = - predicate_request loc situation (request, oinfo) - - let qpredicate_request loc situation (request, oinfo) = let requests = [ TypeErrors. diff --git a/backend/cn/lib/resourceInference.mli b/backend/cn/lib/resourceInference.mli index 016e2243e..5026e289e 100644 --- a/backend/cn/lib/resourceInference.mli +++ b/backend/cn/lib/resourceInference.mli @@ -30,6 +30,12 @@ module Special : sig Request.Predicate.t * (Locations.t * string) option -> (Resource.predicate * int list) Typing.m + val has_predicate + : Locations.t -> + TypeErrors.situation -> + Request.Predicate.t * (Locations.t * string) option -> + bool Typing.m + val qpredicate_request : Locations.t -> TypeErrors.situation -> From e7eaf8cfe2aaa4ca44a47214d9be376bf0a169f1 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Mon, 16 Dec 2024 12:14:58 +0000 Subject: [PATCH 110/148] Add timings to diff-prog --- tests/diff-prog.py | 57 ++++++++++++++++++++++++++++++---------------- 1 file changed, 37 insertions(+), 20 deletions(-) diff --git a/tests/diff-prog.py b/tests/diff-prog.py index 99f47359d..8d373248e 100755 --- a/tests/diff-prog.py +++ b/tests/diff-prog.py @@ -1,12 +1,15 @@ #!/usr/bin/env python3 -import os, sys, re, subprocess, json, difflib, argparse, concurrent.futures +import os, sys, re, subprocess, json, difflib, argparse, concurrent.futures, math def eprint(*args, then_exit=True, **kwargs): print('Error:', *args, file=sys.stderr, **kwargs) if then_exit: exit(1) +def time_cmd(cmd): + return ["/usr/bin/time", "--quiet", "--format", "%e"] + cmd + class Prog: def __init__(self, args, config): @@ -16,11 +19,9 @@ def __init__(self, args, config): self.run_cmd = not args.dry_run self.timeout = config['timeout'] self.name = config['name'] - self.matcher = re.compile(config['filter']) - self.suffix = args.suffix def run(self, test_rel_path): - cmd = [self.prog] + self.args + [test_rel_path] + cmd = time_cmd([self.prog] + self.args + [test_rel_path]) if self.print_cmd: print(' '.join(cmd)) if self.run_cmd: @@ -31,10 +32,11 @@ def run(self, test_rel_path): def output(self, test_rel_path): try: completed = self.run(test_rel_path); - result = ("return code: %d\n%s" % (completed.returncode, completed.stdout)) + lines = completed.stdout.splitlines(True) + time = float(lines[-1]) + return { 'time': time, 'lines' : [("return code: %d\n" % completed.returncode)] + lines[:-1] } except subprocess.TimeoutExpired: - result = "TIMEOUT\n" - return result.splitlines(True) + return { 'time': float(self.timeout), 'lines': ["TIMEOUT\n"] } def get_diff(self, test_rel_path): expect_path = test_rel_path + '.' + self.name @@ -42,9 +44,12 @@ def get_diff(self, test_rel_path): open(expect_path, 'w') with open(expect_path, 'r') as expect: try: - return list(difflib.unified_diff(expect.readlines(), self.output(test_rel_path), expect_path, expect_path)) + output = self.output(test_rel_path) + diff = list(difflib.unified_diff(expect.readlines(), output['lines'], expect_path, expect_path)) + time = output['time'] + return { 'diff': diff, 'time': time } except AttributeError: # dry run - return False + return { 'diff': False, 'time': .0 } def test_files(test_dir, matcher): if not os.path.isdir(test_dir): @@ -54,11 +59,7 @@ def test_files(test_dir, matcher): if matcher.match(filename) is not None: yield os.path.join(root, filename) - -def filter_tests(**kwargs): - test_dir = kwargs['test_dir'] - suffix = kwargs['suffix'] - matcher = kwargs['matcher'] +def filter_tests(test_dir, suffix, matcher): inputs = test_files(test_dir, matcher) if suffix is not None: inputs = list(filter(lambda x : x.endswith(suffix), inputs)) @@ -70,12 +71,18 @@ def filter_tests(**kwargs): eprint(f'*{suffix} not found in {test_dir}') return inputs -def run_tests(prog, **kwargs): - quiet = kwargs['quiet'] - test_rel_paths = list(filter_tests(**kwargs)) +def format_timing(name, value): + return { 'name': name, 'unit': 'Seconds', 'value': value } + +def run_tests(prog, test_rel_paths, quiet, max_workers): + test_rel_paths = list(test_rel_paths) with concurrent.futures.ProcessPoolExecutor() as executor: failed_tests = 0 - for test_rel_path, diff in zip(test_rel_paths, executor.map(prog.get_diff, test_rel_paths)): + timings = [] + for test_rel_path, outcome in zip(test_rel_paths, executor.map(prog.get_diff, test_rel_paths), strict=True): + time = outcome['time'] + diff = outcome['diff'] + timings.append(format_timing(test_rel_path, time)) if not prog.run_cmd: continue pass_fail = '\033[32m[ PASSED ]\033[m' @@ -85,13 +92,22 @@ def run_tests(prog, **kwargs): pass_fail = '\033[31m[ FAILED ]\033[m' if not quiet: print('%s %s' % (pass_fail, test_rel_path)) - return min(failed_tests, 1) + return { 'code': min(failed_tests, 1), 'timings': timings } + +def output_bench(name, timings): + total = { 'name': 'Total benchmark time', 'unit': 'Seconds', 'value': math.fsum(timing['value'] for timing in timings) } + with open(('benchmark-data-%s.json' % name), 'w') as f: + json.dump([total] + timings, f, indent=2) def main(args): with open(args.config) as config_file: config = json.load(config_file) prog = Prog(args, config) - return run_tests(prog, test_dir=os.path.dirname(args.config), suffix=args.suffix, matcher=re.compile(config['filter']), quiet=args.quiet) + files = filter_tests(test_dir=os.path.dirname(args.config), suffix=args.suffix, matcher=re.compile(config['filter'])) + result = run_tests(prog, test_rel_paths=files, quiet=args.quiet, max_workers=(1 if args.bench else None)) + if args.bench: + output_bench(config['name'], result['timings']) + return result['code'] # top level parser = argparse.ArgumentParser(description="Script for running an executable and diffing the output.") @@ -102,6 +118,7 @@ def main(args): parser.add_argument('--dry-run', help='Print but do not run commands.', action='store_true') parser.add_argument('--suffix', help='Uniquely identifying suffix of a file in the test directory.') parser.add_argument('--quiet', help='Don\'t show tests completed so far on std out.', action='store_true') +parser.add_argument('--bench', help='Output a JSON file with benchmarks, including total time.', action='store_true') parser.set_defaults(func=main) # parse args and call func (as set using set_defaults) From 2ee75d67d4a26ee39a2cb44645428b6c47fed2c7 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Tue, 17 Dec 2024 12:46:03 +0000 Subject: [PATCH 111/148] Rename diff-prog args to opts --- tests/diff-prog.py | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/tests/diff-prog.py b/tests/diff-prog.py index 8d373248e..22db97153 100755 --- a/tests/diff-prog.py +++ b/tests/diff-prog.py @@ -12,11 +12,11 @@ def time_cmd(cmd): class Prog: - def __init__(self, args, config): - self.prog = args.prog + def __init__(self, opts, config): + self.prog = opts.prog self.args = config['args'] - self.print_cmd = args.dry_run or args.verbose - self.run_cmd = not args.dry_run + self.print_cmd = opts.dry_run or opts.verbose + self.run_cmd = not opts.dry_run self.timeout = config['timeout'] self.name = config['name'] @@ -99,13 +99,13 @@ def output_bench(name, timings): with open(('benchmark-data-%s.json' % name), 'w') as f: json.dump([total] + timings, f, indent=2) -def main(args): - with open(args.config) as config_file: +def main(opts): + with open(opts.config) as config_file: config = json.load(config_file) - prog = Prog(args, config) - files = filter_tests(test_dir=os.path.dirname(args.config), suffix=args.suffix, matcher=re.compile(config['filter'])) - result = run_tests(prog, test_rel_paths=files, quiet=args.quiet, max_workers=(1 if args.bench else None)) - if args.bench: + prog = Prog(opts, config) + files = filter_tests(test_dir=os.path.dirname(opts.config), suffix=opts.suffix, matcher=re.compile(config['filter'])) + result = run_tests(prog, test_rel_paths=files, quiet=opts.quiet, max_workers=(1 if opts.bench else None)) + if opts.bench: output_bench(config['name'], result['timings']) return result['code'] @@ -122,5 +122,5 @@ def main(args): parser.set_defaults(func=main) # parse args and call func (as set using set_defaults) -args = parser.parse_args() -exit(args.func(args)) +opts = parser.parse_args() +exit(opts.func(opts)) From cc888bfd806a9f0fe2745db13e57e8d5eeab6427 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 19 Dec 2024 16:29:43 -0500 Subject: [PATCH 112/148] [CN-Exec] Error names which function is uninterpreted (#772) --- backend/cn/lib/cn_internal_to_ail.ml | 17 ++++++++++++++--- backend/cn/lib/definition.ml | 25 +++++++++++++++++-------- backend/cn/lib/definition.mli | 2 ++ util/cerb_colour.ml | 7 +++++++ util/cerb_colour.mli | 1 + 5 files changed, 41 insertions(+), 11 deletions(-) diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 203f5a0d8..af3f1af82 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -2949,9 +2949,20 @@ let cn_to_ail_function_internal in (bs, Some (List.map mk_stmt ss)) | Uninterp -> - failwith - "Uninterpreted CN functions not supported at runtime. Please provide a concrete \ - function definition" + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Uninterpreted CN functions not supported at runtime. Please provide \ + a concrete function definition for" + (space + ^^^ squotes (Definition.Function.pp_sig (Sym.pp fn_sym) lf_def) + ^^^ !^"at" + ^^^ Locations.pp lf_def.loc)))) + (); + exit 2 in let ail_record_opt = generate_record_opt fn_sym lf_def.return_bt in let params = List.map (fun (sym, bt) -> (sym, bt_to_ail_ctype bt)) lf_def.args in diff --git a/backend/cn/lib/definition.ml b/backend/cn/lib/definition.ml index 728947d3f..bfcfc6c2a 100644 --- a/backend/cn/lib/definition.ml +++ b/backend/cn/lib/definition.ml @@ -33,18 +33,27 @@ module Function = struct let pp_args xs = - Pp.flow_map - (Pp.break 1) - (fun (sym, typ) -> Pp.parens (Pp.typ (Sym.pp sym) (BaseTypes.pp typ))) - xs + let doc = + Pp.flow_map + (Pp.break 1) + (fun (sym, typ) -> Pp.parens (Pp.typ (Sym.pp sym) (BaseTypes.pp typ))) + xs + in + if PPrint.requirement doc = 0 then + Pp.parens Pp.empty + else + doc + + + let pp_sig nm def = + let open Pp in + nm ^^ pp_args def.args ^^^ colon ^^^ BaseTypes.pp def.return_bt let pp nm def = let open Pp in - nm - ^^ colon - ^^^ pp_args def.args - ^^ colon + pp_sig nm def + ^^^ equals ^/^ match def.body with | Uninterp -> !^"uninterpreted" diff --git a/backend/cn/lib/definition.mli b/backend/cn/lib/definition.mli index 5feaa9c77..fd30bd323 100644 --- a/backend/cn/lib/definition.mli +++ b/backend/cn/lib/definition.mli @@ -20,6 +20,8 @@ module Function : sig val pp_args : (Cerb_frontend.Symbol.sym * unit BaseTypes.t_gen) list -> Pp.document + val pp_sig : Pp.document -> t -> Pp.document + val pp : Pp.document -> t -> Pp.document val open_ : (Sym.t * 'a) list -> IndexTerms.t -> IndexTerms.t list -> IndexTerms.t diff --git a/util/cerb_colour.ml b/util/cerb_colour.ml index 00985d86e..020746f6b 100644 --- a/util/cerb_colour.ml +++ b/util/cerb_colour.ml @@ -34,6 +34,13 @@ let int_fg = function let do_colour = ref (Unix.isatty Unix.stdout) +let with_colour f x = + let col = ! do_colour in + do_colour := true; + let r = f x in + do_colour := col; + r + let without_colour f x = let col = ! do_colour in do_colour := false; diff --git a/util/cerb_colour.mli b/util/cerb_colour.mli index 39b2449ef..8264cba5d 100644 --- a/util/cerb_colour.mli +++ b/util/cerb_colour.mli @@ -16,6 +16,7 @@ type ansi_style = type ansi_format = ansi_style list val do_colour: bool ref +val with_colour: ('a -> 'b) -> 'a -> 'b val without_colour: ('a -> 'b) -> 'a -> 'b val ansi_format: ?err:bool -> ansi_format -> string -> string val pp_ansi_format: ?err:bool -> ansi_format -> (unit -> PPrint.document) -> PPrint.document From 40a2585011f9f04e0bbd47b6b16cb193631a393e Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 19 Dec 2024 17:40:45 -0500 Subject: [PATCH 113/148] [CN-Exec] Extract and use CN-Test-Gen bounds analysis (#773) --- backend/cn/lib/cn_internal_to_ail.ml | 181 +++++++----------- backend/cn/lib/indexTerms.ml | 110 +++++++++++ backend/cn/lib/request.ml | 12 ++ backend/cn/lib/request.mli | 6 + backend/cn/lib/testGeneration/genAnalysis.ml | 75 -------- .../cn/lib/testGeneration/genDistribute.ml | 2 +- backend/cn/lib/testGeneration/genOptimize.ml | 4 +- backend/cn/lib/testGeneration/genRuntime.ml | 2 +- tests/cn-test-gen/src/bounds.pass.c | 35 ++++ tests/cn-test-gen/src/preserve.pass.c | 9 - tests/run-cn-exec.sh | 2 - 11 files changed, 232 insertions(+), 206 deletions(-) create mode 100644 tests/cn-test-gen/src/bounds.pass.c delete mode 100644 tests/cn-test-gen/src/preserve.pass.c diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index af3f1af82..7498064a5 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -498,80 +498,6 @@ let get_equality_fn_call bt e1 e2 _dts = (CF.Pp_utils.to_plain_pretty_string (BT.pp bt))))) -let rearrange_start_inequality sym (IT.(IT (_, _, loc)) as e1) e2 = - match IT.term e2 with - | IT.Binop (binop, (IT.IT (Sym sym1, _, _) as expr1), (IT.IT (Sym sym2, _, _) as expr2)) - -> - if Sym.equal sym sym1 then ( - let inverse_binop = - match binop with - | Add -> IT.Sub - | Sub -> Add - | _ -> failwith "Other binops not supported" - in - IT.(Binop (inverse_binop, e1, expr2))) - else if Sym.equal sym sym2 then ( - match binop with - | Add -> IT.Binop (Sub, e1, expr1) - | Sub -> failwith "Minus not supported" - | _ -> failwith "Other binops not supported") - else - failwith "Not of correct form" - | _ -> - failwith ("TODO rearrange_start_inequality at " ^ Cerb_location.simple_location loc) - - -let generate_start_expr start_cond sym = - let start_expr, binop = - match IT.term start_cond with - | IT.(Binop (binop, expr1, IT.IT (Sym sym', _, _))) -> - if Sym.equal sym sym' then - (expr1, binop) - else - failwith "Not of correct form (unlikely case - i's not matching)" - | IT.(Binop (binop, expr1, expr2)) -> - ( IT.IT - (rearrange_start_inequality sym expr1 expr2, BT.Integer, Cerb_location.unknown), - binop ) - | _ -> failwith "Not of correct form: more complicated RHS of binexpr than just i" - in - match binop with - | LE -> start_expr - | LT -> - let one = - IT.(IT (Const (IT.Z (Z.of_int 1)), IT.bt start_expr, Cerb_location.unknown)) - in - IT.(IT (Binop (Add, start_expr, one), IT.bt start_expr, Cerb_location.unknown)) - | _ -> failwith "Not of correct form: not Le or Lt" - - -let rec get_leftmost_of_and_expr = function - | IT.IT (IT.(Binop (And, lhs, _rhs)), _, _) -> get_leftmost_of_and_expr lhs - | lhs -> lhs - - -let rec get_rest_of_expr_r_aux it = - match IT.term it with - | IT.(Binop (And, lhs, rhs)) -> - let r = get_rest_of_expr_r_aux lhs in - (match IT.term r with - | Const (Bool true) -> rhs - | _ -> IT.IT (IT.(Binop (And, r, rhs)), BT.Bool, IT.loc it)) - | _lhs -> IT.IT (Const (Bool true), BT.Bool, IT.loc it) - - -let get_rest_of_expr_r it = - match IT.term it with - | IT.(Binop (And, lhs, rhs)) -> - let is_simple = - match (IT.term lhs, IT.term rhs) with - | Binop (And, _, _), _ | _, Binop (And, _, _) -> false - | _, _ -> true - in - if is_simple then rhs else get_rest_of_expr_r_aux it - | _ -> IT.IT (Const (Bool true), BT.Bool, IT.loc it) - - let convert_from_cn_bool_sym = Sym.fresh_named (Option.get (get_conversion_from_fn_str BT.Bool)) @@ -2556,6 +2482,64 @@ let cn_to_ail_struct ((sym, (loc, attrs, tag_def)) : A.sigma_tag_definition) | C.UnionDef _ -> [] +let get_while_bounds_and_cond (i_sym, i_bt) it = + (* Translation of q.pointer *) + let i_it = IT.IT (IT.(Sym i_sym), i_bt, Cerb_location.unknown) in + (* Start of range *) + let start_expr = + if BT.equal_sign (fst (Option.get (BT.is_bits_bt i_bt))) BT.Unsigned then + IndexTerms.Bounds.get_lower_bound (i_sym, i_bt) it + else ( + match IndexTerms.Bounds.get_lower_bound_opt (i_sym, i_bt) it with + | Some e -> e + | None -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Cannot infer lower bound for permission" + (squotes (IT.pp it) ^^^ !^"at" ^^^ Locations.pp (IT.loc it))))) + (); + exit 2) + in + let start_expr = + IT.IT (IT.Cast (IT.bt start_expr, start_expr), IT.bt start_expr, Cerb_location.unknown) + in + let start_cond = + match start_expr with + | IT (Binop (Add, start_expr', IT (Const (Bits (_, n)), _, _)), _, _) + when Z.equal n Z.one -> + IT.lt_ (start_expr', i_it) Cerb_location.unknown + | _ -> IT.le_ (start_expr, i_it) Cerb_location.unknown + in + (* End of range *) + let end_expr = + match IndexTerms.Bounds.get_upper_bound_opt (i_sym, i_bt) it with + | Some e -> e + | None -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Cannot infer upper bound for permission" + (squotes (IT.pp it) ^^^ !^"at" ^^^ Locations.pp (IT.loc it))))) + (); + exit 2 + in + let end_cond = + match end_expr with + | IT (Binop (Sub, end_expr', IT (Const (Bits (_, n)), _, _)), _, _) + when Z.equal n Z.one -> + IT.lt_ (i_it, end_expr') Cerb_location.unknown + | _ -> IT.le_ (i_it, end_expr) Cerb_location.unknown + in + (start_expr, end_expr, IT.and2_ (start_cond, end_cond) Cerb_location.unknown) + + (* is_pre used for ownership checking, to see if ownership needs to be taken or put back *) let cn_to_ail_resource_internal ?(is_pre = true) @@ -2654,22 +2638,12 @@ let cn_to_ail_resource_internal } *) let i_sym, i_bt = q.q in - let start_cond = get_leftmost_of_and_expr q.permission in - let start_expr = generate_start_expr start_cond (fst q.q) in - let start_expr = - IT.IT - (IT.Cast (IT.bt start_expr, start_expr), IT.bt start_expr, Cerb_location.unknown) - in + let start_expr, _, while_loop_cond = get_while_bounds_and_cond q.q q.permission in let _, _, e_start = cn_to_ail_expr_internal dts globals start_expr PassBack in - let end_cond = get_leftmost_of_and_expr (get_rest_of_expr_r q.permission) in - let if_stat_cond = get_rest_of_expr_r (get_rest_of_expr_r q.permission) in - let while_loop_cond = - IT.IT (Binop (And, start_cond, end_cond), BT.Bool, Cerb_location.unknown) - in let _, _, while_cond_expr = cn_to_ail_expr_internal dts globals while_loop_cond PassBack in - let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals if_stat_cond PassBack in + let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals q.permission PassBack in let cn_integer_ptr_ctype = bt_to_ail_ctype i_bt in (* let convert_to_cn_integer_sym = Sym.fresh_pretty (Option.get (get_conversion_to_fn_str BT.Integer)) @@ -2876,26 +2850,12 @@ let cn_to_ail_logical_constraint_internal assign/return/assert/passback b *) - let start_cond = get_leftmost_of_and_expr cond_it in - let start_expr = generate_start_expr start_cond sym in - let start_expr = - IT.IT - ( IT.Cast (IT.bt start_expr, start_expr), - IT.bt start_expr, - Cerb_location.unknown ) - in + let start_expr, _, while_loop_cond = get_while_bounds_and_cond (sym, bt) cond_it in let _, _, e_start = cn_to_ail_expr_internal dts globals start_expr PassBack in - let end_cond = get_leftmost_of_and_expr (get_rest_of_expr_r cond_it) in - let if_stat_cond = get_rest_of_expr_r (get_rest_of_expr_r cond_it) in - let while_loop_cond = - IT.IT (Binop (And, start_cond, end_cond), BT.Bool, Cerb_location.unknown) - in let _, _, while_cond_expr = cn_to_ail_expr_internal dts globals while_loop_cond PassBack in - let _, _, if_cond_expr = - cn_to_ail_expr_internal dts globals if_stat_cond PassBack - in + let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals cond_it PassBack in let t_translated = cn_to_ail_expr_internal dts globals t PassBack in let bs, ss, e = gen_bool_while_loop @@ -2957,8 +2917,7 @@ let cn_to_ail_function_internal (Pp.item "Uninterpreted CN functions not supported at runtime. Please provide \ a concrete function definition for" - (space - ^^^ squotes (Definition.Function.pp_sig (Sym.pp fn_sym) lf_def) + (squotes (Definition.Function.pp_sig (Sym.pp fn_sym) lf_def) ^^^ !^"at" ^^^ Locations.pp lf_def.loc)))) (); @@ -3637,22 +3596,12 @@ let cn_to_ail_assume_resource_internal } *) let i_sym, i_bt = q.q in - let start_cond = get_leftmost_of_and_expr q.permission in - let start_expr = generate_start_expr start_cond (fst q.q) in - let start_expr = - IT.IT - (IT.Cast (IT.bt start_expr, start_expr), IT.bt start_expr, Cerb_location.unknown) - in + let start_expr, _, while_loop_cond = get_while_bounds_and_cond q.q q.permission in let _, _, e_start = cn_to_ail_expr_internal dts globals start_expr PassBack in - let end_cond = get_leftmost_of_and_expr (get_rest_of_expr_r q.permission) in - let if_stat_cond = get_rest_of_expr_r (get_rest_of_expr_r q.permission) in - let while_loop_cond = - IT.IT (Binop (And, start_cond, end_cond), BT.Bool, Cerb_location.unknown) - in let _, _, while_cond_expr = cn_to_ail_expr_internal dts globals while_loop_cond PassBack in - let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals if_stat_cond PassBack in + let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals q.permission PassBack in let cn_integer_ptr_ctype = bt_to_ail_ctype i_bt in (* let convert_to_cn_integer_sym = Sym.fresh_pretty (Option.get (get_conversion_to_fn_str BT.Integer)) diff --git a/backend/cn/lib/indexTerms.ml b/backend/cn/lib/indexTerms.ml index 72373c926..458e8d3ef 100644 --- a/backend/cn/lib/indexTerms.ml +++ b/backend/cn/lib/indexTerms.ml @@ -1205,3 +1205,113 @@ let rec map_term_post (f : t -> t) (it : t) : t = | Cast (bt', it') -> Cast (bt', loop it') in f (IT (it_, bt, here)) + + +module Bounds = struct + let get_lower_bound_opt ((x, bt) : Sym.sym * BT.t) (it : t) : t option = + let rec aux (it : t) : t option = + match it with + | IT (Binop (EQ, IT (Sym x', _, _), tm2), _, _) + | IT (Binop (EQ, tm2, IT (Sym x', _, _)), _, _) -> + if Sym.equal x x' then Some tm2 else None + | IT (Binop (LE, it', IT (Sym x', _, _)), _, _) when Sym.equal x x' -> Some it' + | IT (Binop (LT, it', IT (Sym x', _, _)), _, _) when Sym.equal x x' -> + Some + (IT + ( Binop (Add, it', num_lit_ Z.one bt Cerb_location.unknown), + bt, + Cerb_location.unknown )) + | IT (Binop (And, tm1, tm2), _, _) -> + (match (aux tm1, aux tm2) with + | None, None -> None + | None, it' | it', None -> it' + | Some tm1, Some tm2 -> + Some (IT (Binop (Max, tm1, tm2), bt, Cerb_location.unknown))) + | IT (Binop (Or, tm1, tm2), _, _) -> + (match (aux tm1, aux tm2) with + | None, None | None, _ | _, None -> None + | Some tm1, Some tm2 -> + Some (IT (Binop (Min, tm1, tm2), bt, Cerb_location.unknown))) + | _ -> None + in + aux it + + + let get_lower_bound ((x, bt) : Sym.sym * BT.t) (it : t) : t = + let min = + match bt with + | Bits (sign, sz) -> fst (BT.bits_range (sign, sz)) + | _ -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (!^"unsupported type" + ^^^ squotes (BT.pp bt) + ^^^ !^"in permission" + ^^^ squotes (pp it) + ^^^ !^"at" + ^^^ Locations.pp (loc it)))) + (); + exit 2 + in + get_lower_bound_opt (x, bt) it + |> Option.value ~default:(num_lit_ min bt Cerb_location.unknown) + + + let get_upper_bound_opt ((x, bt) : Sym.sym * BT.t) (it : t) : t option = + let rec aux (it : t) : t option = + match it with + | IT (Binop (EQ, IT (Sym x', _, _), tm2), _, _) + | IT (Binop (EQ, tm2, IT (Sym x', _, _)), _, _) -> + if Sym.equal x x' then Some tm2 else None + | IT (Binop (LE, IT (Sym x', _, _), it'), _, _) when Sym.equal x x' -> Some it' + | IT (Binop (LT, IT (Sym x', _, _), it'), _, _) when Sym.equal x x' -> + Some + (IT + ( Binop (Sub, it', num_lit_ Z.one bt Cerb_location.unknown), + bt, + Cerb_location.unknown )) + | IT (Binop (And, tm1, tm2), _, _) -> + (match (aux tm1, aux tm2) with + | None, None -> None + | None, it' | it', None -> it' + | Some tm1, Some tm2 -> + Some (IT (Binop (Min, tm1, tm2), bt, Cerb_location.unknown))) + | IT (Binop (Or, tm1, tm2), _, _) -> + (match (aux tm1, aux tm2) with + | None, None | None, _ | _, None -> None + | Some tm1, Some tm2 -> + Some (IT (Binop (Max, tm1, tm2), bt, Cerb_location.unknown))) + | _ -> None + in + aux it + + + let get_upper_bound ((x, bt) : Sym.sym * BT.t) (it : t) : t = + let max = + match bt with + | Bits (sign, sz) -> snd (BT.bits_range (sign, sz)) + | _ -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (!^"unsupported type" + ^^^ squotes (BT.pp bt) + ^^^ !^"in permission" + ^^^ squotes (pp it) + ^^^ !^"at" + ^^^ Locations.pp (loc it)))) + (); + exit 2 + in + get_upper_bound_opt (x, bt) it + |> Option.value ~default:(num_lit_ max bt Cerb_location.unknown) + + + let get_bounds ((x, bt) : Sym.sym * BT.t) (it : t) : t * t = + (get_lower_bound (x, bt) it, get_upper_bound (x, bt) it) +end diff --git a/backend/cn/lib/request.ml b/backend/cn/lib/request.ml index d274abb33..a8c04409d 100644 --- a/backend/cn/lib/request.ml +++ b/backend/cn/lib/request.ml @@ -1,5 +1,6 @@ open Pp.Infix module IT = IndexTerms +module BT = BaseTypes let pp_maybe_oargs = function None -> Pp.empty | Some oargs -> Pp.parens (IT.pp oargs) @@ -142,6 +143,17 @@ module QPredicate = struct :: dtree_of_name qpred.name :: IT.dtree qpred.pointer :: List.map IT.dtree qpred.iargs ) + + + let get_lower_bound (qpred : t) : IT.t = + IndexTerms.Bounds.get_lower_bound qpred.q qpred.permission + + + let get_upper_bound (qpred : t) : IT.t = + IndexTerms.Bounds.get_upper_bound qpred.q qpred.permission + + + let get_bounds (qpred : t) : IT.t * IT.t = (get_lower_bound qpred, get_upper_bound qpred) end type t = diff --git a/backend/cn/lib/request.mli b/backend/cn/lib/request.mli index 78c7377c9..b7dcc3141 100644 --- a/backend/cn/lib/request.mli +++ b/backend/cn/lib/request.mli @@ -49,6 +49,12 @@ module QPredicate : sig val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t val dtree : t -> Cerb_frontend.Pp_ast.doc_tree + + val get_lower_bound : t -> IndexTerms.t + + val get_upper_bound : t -> IndexTerms.t + + val get_bounds : t -> IndexTerms.t * IndexTerms.t end type t = diff --git a/backend/cn/lib/testGeneration/genAnalysis.ml b/backend/cn/lib/testGeneration/genAnalysis.ml index 0de201d70..8be2748ca 100644 --- a/backend/cn/lib/testGeneration/genAnalysis.ml +++ b/backend/cn/lib/testGeneration/genAnalysis.ml @@ -75,81 +75,6 @@ let get_single_uses ?(pure : bool = false) (gt : GT.t) : Sym.Set.t = |> Sym.Set.of_list -module Bounds = struct - let get_lower_bound ((x, bt) : Sym.sym * BT.t) (it : IT.t) : IT.t = - let min = - match bt with - | Bits (sign, sz) -> fst (BT.bits_range (sign, sz)) - | _ -> failwith "unsupported type for `each`" - in - let rec aux (it : IT.t) : IT.t option = - match it with - | IT (Binop (EQ, IT (Sym x', _, _), tm2), _, _) - | IT (Binop (EQ, tm2, IT (Sym x', _, _)), _, _) -> - if Sym.equal x x' then Some tm2 else None - | IT (Binop (LE, it', IT (Sym x', _, _)), _, _) when Sym.equal x x' -> Some it' - | IT (Binop (LT, it', IT (Sym x', _, _)), _, _) when Sym.equal x x' -> - Some - (IT - ( Binop (Add, it', IT.num_lit_ Z.one bt Cerb_location.unknown), - bt, - Cerb_location.unknown )) - | IT (Binop (And, tm1, tm2), _, _) -> - (match (aux tm1, aux tm2) with - | None, None -> None - | None, it' | it', None -> it' - | Some tm1, Some tm2 -> - Some (IT (Binop (Max, tm1, tm2), bt, Cerb_location.unknown))) - | IT (Binop (Or, tm1, tm2), _, _) -> - (match (aux tm1, aux tm2) with - | None, None | None, _ | _, None -> None - | Some tm1, Some tm2 -> - Some (IT (Binop (Min, tm1, tm2), bt, Cerb_location.unknown))) - | _ -> None - in - aux it |> Option.value ~default:(IT.num_lit_ min bt Cerb_location.unknown) - - - let get_upper_bound ((x, bt) : Sym.sym * BT.t) (it : IT.t) : IT.t = - let max = - match bt with - | Bits (sign, sz) -> snd (BT.bits_range (sign, sz)) - | _ -> failwith "unsupported type for `each`" - in - let rec aux (it : IT.t) : IT.t option = - match it with - | IT (Binop (EQ, IT (Sym x', _, _), tm2), _, _) - | IT (Binop (EQ, tm2, IT (Sym x', _, _)), _, _) -> - if Sym.equal x x' then Some tm2 else None - | IT (Binop (LE, IT (Sym x', _, _), it'), _, _) when Sym.equal x x' -> Some it' - | IT (Binop (LT, IT (Sym x', _, _), it'), _, _) when Sym.equal x x' -> - Some - (IT - ( Binop (Sub, it', IT.num_lit_ Z.one bt Cerb_location.unknown), - bt, - Cerb_location.unknown )) - | IT (Binop (And, tm1, tm2), _, _) -> - (match (aux tm1, aux tm2) with - | None, None -> None - | None, it' | it', None -> it' - | Some tm1, Some tm2 -> - Some (IT (Binop (Min, tm1, tm2), bt, Cerb_location.unknown))) - | IT (Binop (Or, tm1, tm2), _, _) -> - (match (aux tm1, aux tm2) with - | None, None | None, _ | _, None -> None - | Some tm1, Some tm2 -> - Some (IT (Binop (Max, tm1, tm2), bt, Cerb_location.unknown))) - | _ -> None - in - aux it |> Option.value ~default:(IT.num_lit_ max bt Cerb_location.unknown) - - - let get_bounds ((x, bt) : Sym.sym * BT.t) (it : IT.t) : IT.t * IT.t = - (get_lower_bound (x, bt) it, get_upper_bound (x, bt) it) -end - -let get_bounds = Bounds.get_bounds - let get_recursive_preds (preds : (Sym.t * Def.Predicate.t) list) : Sym.Set.t = let get_calls (pred : Def.Predicate.t) : Sym.Set.t = pred.clauses diff --git a/backend/cn/lib/testGeneration/genDistribute.ml b/backend/cn/lib/testGeneration/genDistribute.ml index fa35412b2..451e9f3b4 100644 --- a/backend/cn/lib/testGeneration/genDistribute.ml +++ b/backend/cn/lib/testGeneration/genDistribute.ml @@ -41,7 +41,7 @@ let apply_array_max_length (gt : GT.t) : GT.t = | Assert (lc, gt') -> GT.assert_ (lc, aux gt') here | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux gt_then, aux gt_else) here | Map ((i, i_bt, it_perm), gt') -> - let _it_min, it_max = GenAnalysis.get_bounds (i, i_bt) it_perm in + let _it_min, it_max = IndexTerms.Bounds.get_bounds (i, i_bt) it_perm in let loc = Locations.other __LOC__ in let it_max_min = IT.le_ diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 9ddb9d988..5819f2f56 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -126,7 +126,7 @@ module Fusion = struct ((i, i_bt), (IT (Binop (Implies, it_perm, it_body), _, loc_implies) as it)), gt' ) when Sym.Set.mem x (IT.free_vars it) && check_index_ok x i it -> - let it_min', it_max' = GA.get_bounds (i, i_bt) it_perm in + let it_min', it_max' = IndexTerms.Bounds.get_bounds (i, i_bt) it_perm in let gt', res = aux gt' in if IT.equal it_min it_min' @@ -171,7 +171,7 @@ module Fusion = struct | Let (backtracks, (x, GT (Map ((i, i_bt, it_perm), gt_inner), _, loc_map)), gt_rest) -> - let its_bounds = GA.get_bounds (i, i_bt) it_perm in + let its_bounds = IndexTerms.Bounds.get_bounds (i, i_bt) it_perm in let gt_rest, constraints = collect_constraints (Sym.Set.add x vars) x its_bounds gt_rest in diff --git a/backend/cn/lib/testGeneration/genRuntime.ml b/backend/cn/lib/testGeneration/genRuntime.ml index c58c0baef..aeb40efa3 100644 --- a/backend/cn/lib/testGeneration/genRuntime.ml +++ b/backend/cn/lib/testGeneration/genRuntime.ml @@ -451,7 +451,7 @@ let elaborate_gt (inputs : Sym.Set.t) (gt : GT.t) : term = let path_vars = Sym.Set.union path_vars (IT.free_vars cond) in ITE { bt; cond; t = aux vars path_vars gt_then; f = aux vars path_vars gt_else } | Map ((i, i_bt, perm), inner) -> - let min, max = GenAnalysis.get_bounds (i, i_bt) perm in + let min, max = IndexTerms.Bounds.get_bounds (i, i_bt) perm in Map { i; bt = Map (i_bt, GT.bt inner); diff --git a/tests/cn-test-gen/src/bounds.pass.c b/tests/cn-test-gen/src/bounds.pass.c new file mode 100644 index 000000000..1928980c0 --- /dev/null +++ b/tests/cn-test-gen/src/bounds.pass.c @@ -0,0 +1,35 @@ +void bounds1(int size, int* p) +/*@ +requires + take a1 = each(u64 i; 0u64 <= i && i < (u64)size) { Owned(array_shift(p,i)) }; +ensures + take a2 = each(u64 i; 0u64 <= i && i < (u64)size) { Owned(array_shift(p,i)) }; +@*/ +{} + +void bounds2(int size, int* p) +/*@ +requires + take a1 = each(u64 i; i < (u64)size) { Owned(array_shift(p,i)) }; +ensures + take a2 = each(u64 i; i < (u64)size) { Owned(array_shift(p,i)) }; +@*/ +{} + +void bounds3(int size, int* p) +/*@ +requires + take a1 = each(i32 i; -1i32 < i && i < size) { Owned(array_shift(p,i)) }; +ensures + take a2 = each(i32 i; -1i32 < i && i < size) { Owned(array_shift(p,i)) }; +@*/ +{} + +void bounds4(int* p) +/*@ +requires + take a1 = each(i32 i; i == 1i32 || i == 2i32 || i == 5i32) { Owned(array_shift(p,i)) }; +ensures + take a2 = each(i32 i; i == 1i32 || i == 2i32 || i == 5i32) { Owned(array_shift(p,i)) }; +@*/ +{} diff --git a/tests/cn-test-gen/src/preserve.pass.c b/tests/cn-test-gen/src/preserve.pass.c deleted file mode 100644 index 81657e8e6..000000000 --- a/tests/cn-test-gen/src/preserve.pass.c +++ /dev/null @@ -1,9 +0,0 @@ -void preserve(int size, int *p) -/*@ -requires - take a1 = each(u64 i; 0u64 <= i && i < (u64)size) { Owned(array_shift(p,i)) }; -ensures - take a2 = each(u64 i; 0u64 <= i && i < (u64)size) { Owned(array_shift(p,i)) }; -@*/ -{ -} diff --git a/tests/run-cn-exec.sh b/tests/run-cn-exec.sh index 23e917226..14ca26277 100755 --- a/tests/run-cn-exec.sh +++ b/tests/run-cn-exec.sh @@ -102,7 +102,6 @@ SUCCESS=$(find cn -name '*.c' \ ! -name "int_to_ptr.c" \ ! -name "int_to_ptr.error.c" \ ! -name "create_rdonly.c" \ - ! -name "to_from_bytes_block.c" \ ) # Include files which cause error for proof but not testing @@ -169,7 +168,6 @@ BUGGY="cn/division_casting.c \ cn/int_to_ptr.c \ cn/int_to_ptr.error.c \ cn/create_rdonly.c \ - cn/to_from_bytes_block.c \ " # Exclude files which cause error for proof but not testing From 6791a6c6b67784feb5f8f3b28ebcd08ead22eef9 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 19 Dec 2024 17:41:16 -0500 Subject: [PATCH 114/148] [CN-Exec] Give more info for `Predicate not found` (#775) Also make a distinct message for `Alloc` --- backend/cn/lib/cn_internal_to_ail.ml | 52 ++++++++++++++++++++++++++-- 1 file changed, 49 insertions(+), 3 deletions(-) diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 7498064a5..9aec367f4 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -2548,18 +2548,41 @@ let cn_to_ail_resource_internal dts globals (preds : (Sym.t * Def.Predicate.t) list) - _loc + loc = let calculate_return_type = function | Request.Owned (sct, _) -> ( Sctypes.to_ctype sct, BT.of_sct Memory.is_signed_integer_type Memory.size_of_integer_type sct ) | PName pname -> + if Sym.equal pname Alloc.Predicate.sym then ( + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "'Alloc' not currently supported at runtime" + (!^"Used at" ^^^ Locations.pp loc)))) + (); + exit 2); let matching_preds = List.filter (fun (pred_sym', _def) -> Sym.equal pname pred_sym') preds in let pred_sym', pred_def' = - match matching_preds with [] -> failwith "Predicate not found" | p :: _ -> p + match matching_preds with + | [] -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Predicate not found" + (Sym.pp pname ^^^ !^"at" ^^^ Locations.pp loc)))) + (); + exit 2 + | p :: _ -> p in let cn_bt = bt_to_cn_base_type pred_def'.oarg_bt in let ctype = @@ -3509,11 +3532,34 @@ let cn_to_ail_assume_resource_internal ( Sctypes.to_ctype sct, BT.of_sct Memory.is_signed_integer_type Memory.size_of_integer_type sct ) | PName pname -> + if Sym.equal pname Alloc.Predicate.sym then ( + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "'Alloc' not currently supported at runtime" + (!^"Used at" ^^^ Locations.pp loc)))) + (); + exit 2); let matching_preds = List.filter (fun (pred_sym', _def) -> Sym.equal pname pred_sym') preds in let pred_sym', pred_def' = - match matching_preds with [] -> failwith "Predicate not found" | p :: _ -> p + match matching_preds with + | [] -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Predicate not found" + (Sym.pp pname ^^^ !^"at" ^^^ Locations.pp loc)))) + (); + exit 2 + | p :: _ -> p in let cn_bt = bt_to_cn_base_type pred_def'.oarg_bt in let ctype = From 1ce88c1781b844b56ea49bad1b7c270765b9d120 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Thu, 19 Dec 2024 15:24:51 +0000 Subject: [PATCH 115/148] Fix diff-prog max_workers was not being passed to the ProcessPoolExecutor, which made the --bench flag not work as intended. --- tests/diff-prog.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/diff-prog.py b/tests/diff-prog.py index 22db97153..744f22a61 100755 --- a/tests/diff-prog.py +++ b/tests/diff-prog.py @@ -76,7 +76,7 @@ def format_timing(name, value): def run_tests(prog, test_rel_paths, quiet, max_workers): test_rel_paths = list(test_rel_paths) - with concurrent.futures.ProcessPoolExecutor() as executor: + with concurrent.futures.ProcessPoolExecutor(max_workers=max_workers) as executor: failed_tests = 0 timings = [] for test_rel_path, outcome in zip(test_rel_paths, executor.map(prog.get_diff, test_rel_paths), strict=True): From 07660554671aa1989ead2fe527933d0441abaebc Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Fri, 20 Dec 2024 17:49:32 +0000 Subject: [PATCH 116/148] CN: Error on unused modules --- backend/cn/bin/dune | 2 +- backend/cn/lib/core_to_mucore.ml | 3 --- backend/cn/lib/definition.ml | 1 - backend/cn/lib/dune | 2 +- backend/cn/lib/explain.ml | 6 ------ backend/cn/lib/request.ml | 1 - backend/cn/lib/solver.ml | 4 ---- backend/cn/lib/testGeneration/genCodeGen.ml | 1 - backend/cn/lib/testGeneration/genCompile.ml | 1 - backend/cn/lib/testGeneration/genDistribute.ml | 1 - backend/cn/lib/testGeneration/specTests.ml | 1 - backend/cn/lib/typing.ml | 2 -- 12 files changed, 2 insertions(+), 23 deletions(-) diff --git a/backend/cn/bin/dune b/backend/cn/bin/dune index 94f3f9550..5ff6a3fbd 100644 --- a/backend/cn/bin/dune +++ b/backend/cn/bin/dune @@ -4,7 +4,7 @@ (public_name cn) (package cn) (flags - (:standard -w -37 -open Monomorphic.Int)) + (:standard -w @60 -open Monomorphic.Int)) (libraries cerb_backend cerb_frontend diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 7bca6a7e2..c2159cac3 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -8,7 +8,6 @@ module Ctype = CF.Ctype module BT = BaseTypes module C = Compile module IT = IndexTerms -module IdMap = Map.Make (Id) module SBT = BaseTypes.Surface module Mu = Mucore @@ -849,9 +848,7 @@ let rec n_expr | Eexcluded _ -> assert_error loc !^"core_anormalisation: Eexcluded" -module RT = ReturnTypes module AT = ArgumentTypes -module LRT = LogicalReturnTypes module LAT = LogicalArgumentTypes let rec lat_of_arguments f_i = function diff --git a/backend/cn/lib/definition.ml b/backend/cn/lib/definition.ml index bfcfc6c2a..4db2a43a0 100644 --- a/backend/cn/lib/definition.ml +++ b/backend/cn/lib/definition.ml @@ -1,5 +1,4 @@ module IT = IndexTerms -module AT = ArgumentTypes module LAT = LogicalArgumentTypes module Function = struct diff --git a/backend/cn/lib/dune b/backend/cn/lib/dune index b82d2f8e3..93d190369 100644 --- a/backend/cn/lib/dune +++ b/backend/cn/lib/dune @@ -4,7 +4,7 @@ (name cn) (public_name cn) (flags - (:standard -w -37 -open Monomorphic.Int)) + (:standard -w @60 -open Monomorphic.Int)) (libraries cerb_backend cerb_frontend diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index e42c39f12..e0990d322 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -1,16 +1,10 @@ open Report module IT = IndexTerms -module BT = BaseTypes -module Res = Resource module Def = Definition module Req = Request -module LC = LogicalConstraints module LF = Definition.Function module LAT = LogicalArgumentTypes -module StringMap = Map.Make (String) module C = Context -module Loc = Locations -module S = Solver open Request open IndexTerms open Pp diff --git a/backend/cn/lib/request.ml b/backend/cn/lib/request.ml index a8c04409d..b37fa7812 100644 --- a/backend/cn/lib/request.ml +++ b/backend/cn/lib/request.ml @@ -1,6 +1,5 @@ open Pp.Infix module IT = IndexTerms -module BT = BaseTypes let pp_maybe_oargs = function None -> Pp.empty | Some oargs -> Pp.parens (IT.pp oargs) diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 141293aae..63f7b19e5 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -1,7 +1,5 @@ module SMT = Simple_smt -module IT = IndexTerms open IndexTerms -module BT = BaseTypes open BaseTypes module LC = LogicalConstraints open LogicalConstraints @@ -17,8 +15,6 @@ module Int_BT_Table = Map.Make (struct BT.compare bt1 bt2 end) -module BT_Table = Hashtbl.Make (BT) - module IntWithHash = struct (* For compatability with older ocamls *) include Int diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index 5e0ef5592..549278d2d 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -6,7 +6,6 @@ module Utils = Executable_spec_utils module BT = BaseTypes module IT = IndexTerms module LC = LogicalConstraints -module GT = GenTerms module GR = GenRuntime let mk_expr = Utils.mk_expr diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index f372fb22a..d6862e293 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -9,7 +9,6 @@ module GBT = GenBaseTypes module GT = GenTerms module GD = GenDefinitions module Config = TestGenConfig -module CtA = Cn_internal_to_ail type s = GD.context diff --git a/backend/cn/lib/testGeneration/genDistribute.ml b/backend/cn/lib/testGeneration/genDistribute.ml index 451e9f3b4..3a1cbc798 100644 --- a/backend/cn/lib/testGeneration/genDistribute.ml +++ b/backend/cn/lib/testGeneration/genDistribute.ml @@ -3,7 +3,6 @@ module IT = IndexTerms module LC = LogicalConstraints module GT = GenTerms module GD = GenDefinitions -module GA = GenAnalysis module Config = TestGenConfig let generated_size (bt : BT.t) : int = diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 9709f2ccd..67c921d3c 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -1,7 +1,6 @@ module CF = Cerb_frontend module A = CF.AilSyntax module C = CF.Ctype -module BT = BaseTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes module CtA = Cn_internal_to_ail diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index c4f74ef25..a5377aa66 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -1,8 +1,6 @@ open Context module IT = IndexTerms module ITSet = Set.Make (IT) -module Req = Request -module Res = Resource open TypeErrors type solver = Solver.solver From d80d8465215c1a3881314d92d41f12e6c4ce471d Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Fri, 20 Dec 2024 18:36:52 +0000 Subject: [PATCH 117/148] Fix #779: Mark offset off as an integer constant --- frontend/model/cabs_to_ail.lem | 7 +++++-- tests/cn/offsetof_int_const.c | 5 +++++ tests/cn/offsetof_int_const.c.verify | 1 + tests/run-cn-exec.sh | 2 ++ 4 files changed, 13 insertions(+), 2 deletions(-) create mode 100644 tests/cn/offsetof_int_const.c create mode 100644 tests/cn/offsetof_int_const.c.verify diff --git a/frontend/model/cabs_to_ail.lem b/frontend/model/cabs_to_ail.lem index 8907f3cdf..7cf36c554 100644 --- a/frontend/model/cabs_to_ail.lem +++ b/frontend/model/cabs_to_ail.lem @@ -601,7 +601,8 @@ let rec is_integer_constant_expression (AnnotatedExpression () _ loc expr_ as ex | AilEassert _ -> E.return false | AilEoffsetof _ _ -> - E.fail loc (Errors.Desugar_NotYetSupported "offsetof() in `integer constant expressions'") + (* STD §7.19#3 *) + E.return true | AilEstr _ -> E.return false (* @@ -833,7 +834,9 @@ let rec is_arithmetic_constant_expression is_lvalue ((AnnotatedExpression () _ l (* E.return true *) (* TODO: is_lvalue might be wrong depending on the type of e? *) is_arithmetic_constant_expression is_lvalue e - + | AilEoffsetof _ _ -> + (* STD §7.19#3 *) + E.return true | _ -> E.return false diff --git a/tests/cn/offsetof_int_const.c b/tests/cn/offsetof_int_const.c new file mode 100644 index 000000000..24df04c7b --- /dev/null +++ b/tests/cn/offsetof_int_const.c @@ -0,0 +1,5 @@ +typedef struct a { + int b; + int c; +} a; +_Static_assert(offsetof(a, c) == sizeof(int), "no gap"); diff --git a/tests/cn/offsetof_int_const.c.verify b/tests/cn/offsetof_int_const.c.verify new file mode 100644 index 000000000..e1522bb41 --- /dev/null +++ b/tests/cn/offsetof_int_const.c.verify @@ -0,0 +1 @@ +return code: 0 diff --git a/tests/run-cn-exec.sh b/tests/run-cn-exec.sh index 14ca26277..1f7319fd6 100755 --- a/tests/run-cn-exec.sh +++ b/tests/run-cn-exec.sh @@ -102,6 +102,7 @@ SUCCESS=$(find cn -name '*.c' \ ! -name "int_to_ptr.c" \ ! -name "int_to_ptr.error.c" \ ! -name "create_rdonly.c" \ + ! -name "offsetof_int_const.c" \ ) # Include files which cause error for proof but not testing @@ -168,6 +169,7 @@ BUGGY="cn/division_casting.c \ cn/int_to_ptr.c \ cn/int_to_ptr.error.c \ cn/create_rdonly.c \ + cn/offsetof_int_const.c \ " # Exclude files which cause error for proof but not testing From 695380a7dd4847795cffd8174a042a51657243ed Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Sat, 21 Dec 2024 21:01:59 +0000 Subject: [PATCH 118/148] increase maximum CN tuple arity, as needed by pgtable (#782) --- backend/cn/lib/solver.ml | 1450 ++++++++++++++++++-------------------- 1 file changed, 680 insertions(+), 770 deletions(-) diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 63f7b19e5..a6803c607 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -5,15 +5,12 @@ module LC = LogicalConstraints open LogicalConstraints module Int_BT_Table = Map.Make (struct - type t = int * BT.t + type t = int * BT.t - let compare (int1, bt1) (int2, bt2) = - let cmp = Int.compare int1 int2 in - if cmp != 0 then - cmp - else - BT.compare bt1 bt2 - end) + let compare (int1, bt1) (int2, bt2) = + let cmp = Int.compare int1 int2 in + if cmp != 0 then cmp else BT.compare bt1 bt2 +end) module IntWithHash = struct (* For compatability with older ocamls *) @@ -30,79 +27,67 @@ open Pp (** Functions that pick names for things. *) module CN_Names = struct let var_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let named_expr_name = "_cn_named" - let uninterpreted_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let struct_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let struct_con_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let struct_field_name x = Id.pp_string x ^ "_struct_fld" - let datatype_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let datatype_con_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let datatype_field_name x = Id.pp_string x ^ "_data_fld" end (** Names for constants that may be uninterpreted. See [bt_uninterpreted] *) module CN_Constant = struct let default = ("default_uf", 0) - let mul = ("mul_uf", 1) - let div = ("div_uf", 2) - let exp = ("exp_uf", 3) - let rem = ("rem_uf", 4) - let mod' = ("mod_uf", 5) - let nth_list = ("nth_list_uf", 6) - let array_to_list = ("array_to_list_uf", 7) end -type solver_frame = - { mutable commands : SMT.sexp list; (** Ack-style SMT commands, most recent first. *) - mutable uninterpreted : SMT.sexp Sym.Map.t; - (** Uninterpreted functions and variables that we've declared. *) - mutable bt_uninterpreted : SMT.sexp Int_BT_Table.t; - (** Uninterpreted constants, indexed by base type. *) - mutable ctypes : int CTypeMap.t - (** Declarations for C types. Each C type is assigned a unique integer. *) - } +type solver_frame = { + mutable commands : SMT.sexp list; + (** Ack-style SMT commands, most recent first. *) + mutable uninterpreted : SMT.sexp Sym.Map.t; + (** Uninterpreted functions and variables that we've declared. *) + mutable bt_uninterpreted : SMT.sexp Int_BT_Table.t; + (** Uninterpreted constants, indexed by base type. *) + mutable ctypes : int CTypeMap.t; + (** Declarations for C types. Each C type is assigned a unique integer. *) +} let empty_solver_frame () = - { commands = []; + { + commands = []; uninterpreted = Sym.Map.empty; bt_uninterpreted = Int_BT_Table.empty; - ctypes = CTypeMap.empty + ctypes = CTypeMap.empty; } - let copy_solver_frame f = { f with commands = f.commands } -type solver = - { smt_solver : SMT.solver; (** The SMT solver connection. *) - cur_frame : solver_frame ref; - prev_frames : solver_frame list ref; - (** Push/pop model. Current frame, and previous frames. *) - name_seed : int ref; (** Used to generate names. *) - (* ISD: This could, perhaps, go in the frame. Then when we pop frames, we'd go back to - the old numbers, which should be OK, I think? *) - globals : Global.t - } +type solver = { + smt_solver : SMT.solver; (** The SMT solver connection. *) + cur_frame : solver_frame ref; + prev_frames : solver_frame list ref; + (** Push/pop model. Current frame, and previous frames. *) + name_seed : int ref; (** Used to generate names. *) + (* ISD: This could, perhaps, go in the frame. Then when we pop frames, we'd go back to + the old numbers, which should be OK, I think? *) + globals : Global.t; +} module Debug = struct let dump_frame (f : solver_frame) = let to_string = Sexplib.Sexp.to_string_hum in let append str doc = doc ^/^ !^str in - let dump_sym k v rest = rest ^/^ bar ^^^ Sym.pp k ^^^ !^"|->" ^^^ !^(to_string v) in + let dump_sym k v rest = + rest ^/^ bar ^^^ Sym.pp k ^^^ !^"|->" ^^^ !^(to_string v) + in let dump_bts (_, k) v rest = rest ^/^ bar ^^^ BT.pp k ^^^ !^"|->" ^^^ !^(to_string v) in @@ -112,10 +97,10 @@ module Debug = struct |> Int_BT_Table.fold dump_bts f.bt_uninterpreted |> append "+---------------------------------" - let dump_solver solver = !^"\n|~~~~~~ Start Solver Dump ~~~~~~~|" - ^/^ separate_map hardline dump_frame (!(solver.cur_frame) :: !(solver.prev_frames)) + ^/^ separate_map hardline dump_frame + (!(solver.cur_frame) :: !(solver.prev_frames)) ^/^ !^"|~~~~~~ End Solver Dump ~~~~~~~~~|" end @@ -127,18 +112,17 @@ let search_frames s f = List.find_map f (!(s.cur_frame) :: !(s.prev_frames)) let find_c_type s ty = let rec search count frames = match frames with - | f :: more -> - (match CTypeMap.find_opt ty f.ctypes with - | Some n -> n - | None -> search (CTypeMap.cardinal f.ctypes + count) more) + | f :: more -> ( + match CTypeMap.find_opt ty f.ctypes with + | Some n -> n + | None -> search (CTypeMap.cardinal f.ctypes + count) more) | [] -> - let f = !(s.cur_frame) in - f.ctypes <- CTypeMap.add ty count f.ctypes; - count + let f = !(s.cur_frame) in + f.ctypes <- CTypeMap.add ty count f.ctypes; + count in search 0 (!(s.cur_frame) :: !(s.prev_frames)) - (** Compute a table mapping ints to C types. We use this to map SMT results back to terms. *) let get_ctype_table s = @@ -148,41 +132,35 @@ let get_ctype_table s = List.iter do_frame (!(s.cur_frame) :: !(s.prev_frames)); table - let debug_ack_command s cmd = - try SMT.ack_command s.smt_solver cmd with - | SMT.UnexpectedSolverResponse r -> + try SMT.ack_command s.smt_solver cmd + with SMT.UnexpectedSolverResponse r -> debug 10 (lazy (!^"failed to ack:" ^/^ !^(Sexplib.Sexp.to_string_hum cmd))); debug 10 (lazy (Debug.dump_solver s)); raise (SMT.UnexpectedSolverResponse r) - (** Start a new scope. *) let push s = debug_ack_command s (SMT.push 1); s.prev_frames := !(s.cur_frame) :: !(s.prev_frames); s.cur_frame := empty_solver_frame () - (** Return to the previous scope. Assumes that there is a previous scope. *) let pop s n = - if n = 0 then - () + if n = 0 then () else ( debug_ack_command s (SMT.pop n); let rec drop count xs = match xs with | new_cur :: new_rest -> - if count = 1 then ( - s.cur_frame := new_cur; - s.prev_frames := new_rest) - else - drop (count - 1) new_rest + if count = 1 then ( + s.cur_frame := new_cur; + s.prev_frames := new_rest) + else drop (count - 1) new_rest | _ -> assert false in drop n !(s.prev_frames)) - let num_scopes s = List.length !(s.prev_frames) (** Do an ack_style command. These are logged. *) @@ -191,7 +169,6 @@ let ack_command s cmd = let f = !(s.cur_frame) in f.commands <- cmd :: f.commands - (** Generate a fersh name *) let fresh_name s x = let n = !(s.name_seed) in @@ -199,20 +176,18 @@ let fresh_name s x = let res = x ^ "_" ^ string_of_int n in res - (** Declare an uninterpreted function. *) let declare_uninterpreted s name args_ts res_t = let check f = Sym.Map.find_opt name f.uninterpreted in match search_frames s check with | Some e -> e | None -> - let sname = CN_Names.uninterpreted_name name in - ack_command s (SMT.declare_fun sname args_ts res_t); - let e = SMT.atom sname in - let f = !(s.cur_frame) in - f.uninterpreted <- Sym.Map.add name e f.uninterpreted; - e - + let sname = CN_Names.uninterpreted_name name in + ack_command s (SMT.declare_fun sname args_ts res_t); + let e = SMT.atom sname in + let f = !(s.cur_frame) in + f.uninterpreted <- Sym.Map.add name e f.uninterpreted; + e (** Declare an uninterpreted function, indexed by a base type. *) let declare_bt_uninterpreted s (name, k) bt args_ts res_t = @@ -220,13 +195,12 @@ let declare_bt_uninterpreted s (name, k) bt args_ts res_t = match search_frames s check with | Some e -> e | None -> - let sname = fresh_name s name in - ack_command s (SMT.declare_fun sname args_ts res_t); - let e = SMT.atom sname in - let top_map = !(s.cur_frame).bt_uninterpreted in - !(s.cur_frame).bt_uninterpreted <- Int_BT_Table.add (k, bt) e top_map; - e - + let sname = fresh_name s name in + ack_command s (SMT.declare_fun sname args_ts res_t); + let e = SMT.atom sname in + let top_map = !(s.cur_frame).bt_uninterpreted in + !(s.cur_frame).bt_uninterpreted <- Int_BT_Table.add (k, bt) e top_map; + e (* Note: CVC5 has support for arbitrary tuples without declaring them. Also, instead of declaring a fixed number of tuples ahead of time, we could declare the types on demand @@ -238,13 +212,11 @@ module CN_Tuple = struct let selector arity field = "cn_get_" ^ string_of_int field ^ "_of_" ^ string_of_int arity - (** A tuple type with the given name *) let t tys = let arity = List.length tys in SMT.app_ (name arity) tys - (** Declare a datatype for a struct *) let declare s arity = let name = name arity in @@ -254,13 +226,11 @@ module CN_Tuple = struct let fields = List.init arity field in ack_command s (SMT.declare_datatype name params [ (name, fields) ]) - (** Make a tuple value *) let con es = let arity = List.length es in SMT.app_ (name arity) es - (** Get a field of a tuple *) let get arity field tup = SMT.app_ (selector arity field) [ tup ] end @@ -278,11 +248,8 @@ end module CN_MemByte = struct let name = "mem_byte" - let alloc_id_name = "alloc_id" - let value_name = "value" - let alloc_id_value_name = "AiV" (** Bit-width of memory bytes *) @@ -295,31 +262,28 @@ module CN_MemByte = struct let con ~alloc_id ~value = SMT.app_ alloc_id_value_name [ alloc_id; value ] let declare s = - ack_command - s - (SMT.declare_datatype - name - [] - [ ( alloc_id_value_name, - [ (alloc_id_name, CN_AllocId.t ()); (value_name, SMT.t_bits width) ] ) + ack_command s + (SMT.declare_datatype name [] + [ + ( alloc_id_value_name, + [ + (alloc_id_name, CN_AllocId.t ()); (value_name, SMT.t_bits width); + ] ); ]) end module CN_Pointer = struct let name = "pointer" - let null_name = "NULL" - let alloc_id_addr_name = "AiA" - let alloc_id_name = "alloc_id" - let addr_name = "addr" (** Bit-width of pointers *) let width = - match Memory.uintptr_bt with Bits (_, w) -> w | _ -> failwith "Pointer is not bits" - + match Memory.uintptr_bt with + | Bits (_, w) -> w + | _ -> failwith "Pointer is not bits" (** The name of the pointer type *) let t = SMT.atom name @@ -328,24 +292,18 @@ module CN_Pointer = struct i.e. adding a [functpr] constructor. *) let match_ptr scrutinee ~null_case ~alloc_id_addr_case = SMT.( - match_datatype - scrutinee - [ (PCon (null_name, []), null_case); + match_datatype scrutinee + [ + (PCon (null_name, []), null_case); ( PCon (alloc_id_addr_name, [ alloc_id_name; addr_name ]), - alloc_id_addr_case - ~alloc_id:(SMT.atom alloc_id_name) - ~addr:(SMT.atom addr_name) ) + alloc_id_addr_case ~alloc_id:(SMT.atom alloc_id_name) + ~addr:(SMT.atom addr_name) ); ]) - let ptr_shift_name = "ptr_shift" - let copy_alloc_id_name = "copy_alloc_id" - let alloc_id_of_name = "alloc_id_of" - let bits_to_ptr_name = "bits_to_ptr" - let addr_of_name = "addr_of" (** Make a null pointer value *) @@ -355,115 +313,80 @@ module CN_Pointer = struct let con_aia ~alloc_id ~addr = SMT.app_ alloc_id_addr_name [ alloc_id; addr ] let declare s = - ack_command - s - (SMT.declare_datatype - name - [] - [ (null_name, []); + ack_command s + (SMT.declare_datatype name [] + [ + (null_name, []); ( alloc_id_addr_name, - [ (alloc_id_name, CN_AllocId.t ()); (addr_name, SMT.t_bits width) ] ) + [ (alloc_id_name, CN_AllocId.t ()); (addr_name, SMT.t_bits width) ] + ); ]); - ack_command - s - (SMT.define_fun - ptr_shift_name + ack_command s + (SMT.define_fun ptr_shift_name [ ("p", t); ("offset", SMT.t_bits width); ("null_case", t) ] t - (match_ptr - (SMT.atom "p") - ~null_case:(SMT.atom "null_case") + (match_ptr (SMT.atom "p") ~null_case:(SMT.atom "null_case") ~alloc_id_addr_case:(fun ~alloc_id ~addr -> con_aia ~alloc_id ~addr:(SMT.bv_add addr (SMT.atom "offset"))))); - ack_command - s - (SMT.define_fun - copy_alloc_id_name + ack_command s + (SMT.define_fun copy_alloc_id_name [ ("p", t); ("new_addr", SMT.t_bits width); ("null_case", t) ] t - (match_ptr - (SMT.atom "p") - ~null_case:(SMT.atom "null_case") + (match_ptr (SMT.atom "p") ~null_case:(SMT.atom "null_case") ~alloc_id_addr_case:(fun ~alloc_id ~addr:_ -> con_aia ~alloc_id ~addr:(SMT.atom "new_addr")))); - ack_command - s - (SMT.define_fun - alloc_id_of_name + ack_command s + (SMT.define_fun alloc_id_of_name [ ("p", t); ("null_case", CN_AllocId.t ()) ] (CN_AllocId.t ()) - (match_ptr - (SMT.atom "p") - ~null_case:(SMT.atom "null_case") + (match_ptr (SMT.atom "p") ~null_case:(SMT.atom "null_case") ~alloc_id_addr_case:(fun ~alloc_id ~addr:_ -> alloc_id))); - ack_command - s - (SMT.define_fun - bits_to_ptr_name + ack_command s + (SMT.define_fun bits_to_ptr_name [ ("bits", SMT.t_bits width); ("alloc_id", CN_AllocId.t ()) ] t (SMT.ite (SMT.eq (SMT.atom "bits") (SMT.bv_k width Z.zero)) con_null (con_aia ~addr:(SMT.atom "bits") ~alloc_id:(SMT.atom "alloc_id")))); - ack_command - s - (SMT.define_fun - addr_of_name + ack_command s + (SMT.define_fun addr_of_name [ ("p", t) ] (SMT.t_bits width) - (match_ptr - (SMT.atom "p") - ~null_case:(SMT.bv_k width Z.zero) + (match_ptr (SMT.atom "p") ~null_case:(SMT.bv_k width Z.zero) ~alloc_id_addr_case:(fun ~alloc_id:_ ~addr -> addr))) - let ptr_shift ~ptr ~offset ~null_case = SMT.app_ ptr_shift_name [ ptr; offset; null_case ] - let copy_alloc_id ~ptr ~addr ~null_case = SMT.app_ copy_alloc_id_name [ ptr; addr; null_case ] - let alloc_id_of ~ptr ~null_case = SMT.app_ alloc_id_of_name [ ptr; null_case ] - let bits_to_ptr ~bits ~alloc_id = SMT.app_ bits_to_ptr_name [ bits; alloc_id ] - let addr_of ~ptr = SMT.app_ addr_of_name [ ptr ] end module CN_List = struct let name = "cn_list" - let nil_name = "cn_nil" - let cons_name = "cn_cons" - let head_name = "cn_head" - let tail_name = "cn_tail" - let t a = SMT.app_ name [ a ] let declare s = let a = SMT.atom "a" in - ack_command - s - (SMT.declare_datatype - name - [ "a" ] + ack_command s + (SMT.declare_datatype name [ "a" ] [ (nil_name, []); (cons_name, [ (head_name, a); (tail_name, t a) ]) ]) - let nil elT = SMT.as_type (SMT.atom nil_name) (t elT) - let cons x xs = SMT.app_ cons_name [ x; xs ] let head xs orelse = SMT.ite (SMT.is_con cons_name xs) (SMT.app_ head_name [ xs ]) orelse - let tail xs orelse = SMT.ite (SMT.is_con cons_name xs) (SMT.app_ tail_name [ xs ]) orelse end @@ -488,9 +411,8 @@ let rec translate_base_type = function | Struct tag -> SMT.atom (CN_Names.struct_name tag) | Datatype tag -> SMT.atom (CN_Names.datatype_name tag) | Record members -> - let get_val (_, v) = v in - translate_base_type (Tuple (List.map get_val members)) - + let get_val (_, v) = v in + translate_base_type (Tuple (List.map get_val members)) (** {1 SMT to Term} *) @@ -498,88 +420,91 @@ let rec translate_base_type = function let rec get_ivalue gs ctys bt sexp = IT (get_value gs ctys bt sexp, bt, Cerb_location.unknown) - and get_value gs ctys bt (sexp : SMT.sexp) = match bt with | Unit -> Const Unit | Bool -> Const (Bool (SMT.to_bool sexp)) | Integer -> Const (Z (SMT.to_z sexp)) | Bits (sign, n) -> - let signed = equal_sign sign Signed in - Const (Bits ((sign, n), SMT.to_bits n signed sexp)) + let signed = equal_sign sign Signed in + Const (Bits ((sign, n), SMT.to_bits n signed sexp)) | Real -> Const (Q (SMT.to_q sexp)) - | MemByte -> - (match SMT.to_con sexp with - | con, [ salloc_id; svalue ] when String.equal con CN_MemByte.alloc_id_value_name -> - let alloc_id = CN_AllocId.from_sexp salloc_id in - let value = - match get_value gs ctys (BT.Bits (Unsigned, CN_MemByte.width)) svalue with - | Const (Bits (_, z)) -> z - | _ -> failwith "Memory byte value is not bits" - in - Const (MemByte { alloc_id; value }) - | _ -> failwith "MemByte") - | Loc () -> - (match SMT.to_con sexp with - | con, [] when String.equal con CN_Pointer.null_name -> Const Null - | con, [ sbase; saddr ] when String.equal con CN_Pointer.alloc_id_addr_name -> - let base = CN_AllocId.from_sexp sbase in - let addr = - match get_value gs ctys Memory.uintptr_bt saddr with - | Const (Bits (_, z)) -> z - | _ -> failwith "Pointer value is not bits" - in - Const (Pointer { alloc_id = base; addr }) - | _ -> failwith "Loc") + | MemByte -> ( + match SMT.to_con sexp with + | con, [ salloc_id; svalue ] + when String.equal con CN_MemByte.alloc_id_value_name -> + let alloc_id = CN_AllocId.from_sexp salloc_id in + let value = + match + get_value gs ctys (BT.Bits (Unsigned, CN_MemByte.width)) svalue + with + | Const (Bits (_, z)) -> z + | _ -> failwith "Memory byte value is not bits" + in + Const (MemByte { alloc_id; value }) + | _ -> failwith "MemByte") + | Loc () -> ( + match SMT.to_con sexp with + | con, [] when String.equal con CN_Pointer.null_name -> Const Null + | con, [ sbase; saddr ] + when String.equal con CN_Pointer.alloc_id_addr_name -> + let base = CN_AllocId.from_sexp sbase in + let addr = + match get_value gs ctys Memory.uintptr_bt saddr with + | Const (Bits (_, z)) -> z + | _ -> failwith "Pointer value is not bits" + in + Const (Pointer { alloc_id = base; addr }) + | _ -> failwith "Loc") | Alloc_id -> Const (Alloc_id (CN_AllocId.from_sexp sexp)) - | CType -> - (try Const (CType_const (Int_Table.find ctys (Z.to_int (SMT.to_z sexp)))) with - | Not_found -> Const (Default bt)) - | List elT -> - (match SMT.to_con sexp with - | con, [] when String.equal con CN_List.nil_name -> Nil elT - | con, [ h; t ] when String.equal con CN_List.cons_name -> - Cons (get_ivalue gs ctys elT h, get_ivalue gs ctys bt t) - | _ -> failwith "List") + | CType -> ( + try Const (CType_const (Int_Table.find ctys (Z.to_int (SMT.to_z sexp)))) + with Not_found -> Const (Default bt)) + | List elT -> ( + match SMT.to_con sexp with + | con, [] when String.equal con CN_List.nil_name -> Nil elT + | con, [ h; t ] when String.equal con CN_List.cons_name -> + Cons (get_ivalue gs ctys elT h, get_ivalue gs ctys bt t) + | _ -> failwith "List") | Set _bt -> Const (Default bt) (* FIXME *) | Map (kt, vt) -> - let els, dflt = SMT.to_array sexp in - let base = MapConst (kt, get_ivalue gs ctys vt dflt) in - let add_el (k, v) a = - MapSet - ( IT (a, bt, Cerb_location.unknown), - get_ivalue gs ctys kt k, - get_ivalue gs ctys vt v ) - in - List.fold_right add_el els base + let els, dflt = SMT.to_array sexp in + let base = MapConst (kt, get_ivalue gs ctys vt dflt) in + let add_el (k, v) a = + MapSet + ( IT (a, bt, Cerb_location.unknown), + get_ivalue gs ctys kt k, + get_ivalue gs ctys vt v ) + in + List.fold_right add_el els base | Tuple bts -> - let _con, vals = SMT.to_con sexp in - Tuple (List.map2 (get_ivalue gs ctys) bts vals) + let _con, vals = SMT.to_con sexp in + Tuple (List.map2 (get_ivalue gs ctys) bts vals) | Struct tag -> - let _con, vals = SMT.to_con sexp in - let decl = Sym.Map.find tag gs.struct_decls in - let fields = List.filter_map (fun x -> x.Memory.member_or_padding) decl in - let mk_field (l, t) v = (l, get_ivalue gs ctys (Memory.bt_of_sct t) v) in - Struct (tag, List.map2 mk_field fields vals) - | Datatype tag -> - let con, vals = SMT.to_con sexp in - let cons = (Sym.Map.find tag gs.datatypes).constrs in - let do_con c = - let fields = (Sym.Map.find c gs.datatype_constrs).params in - let mk_field (l, t) v = (l, get_ivalue gs ctys t v) in - Constructor (c, List.map2 mk_field fields vals) - in - let try_con c = - if String.equal con (CN_Names.datatype_con_name c) then Some (do_con c) else None - in - (match List.find_map try_con cons with - | Some yes -> yes - | None -> failwith "Missing constructor") + let _con, vals = SMT.to_con sexp in + let decl = Sym.Map.find tag gs.struct_decls in + let fields = List.filter_map (fun x -> x.Memory.member_or_padding) decl in + let mk_field (l, t) v = (l, get_ivalue gs ctys (Memory.bt_of_sct t) v) in + Struct (tag, List.map2 mk_field fields vals) + | Datatype tag -> ( + let con, vals = SMT.to_con sexp in + let cons = (Sym.Map.find tag gs.datatypes).constrs in + let do_con c = + let fields = (Sym.Map.find c gs.datatype_constrs).params in + let mk_field (l, t) v = (l, get_ivalue gs ctys t v) in + Constructor (c, List.map2 mk_field fields vals) + in + let try_con c = + if String.equal con (CN_Names.datatype_con_name c) then Some (do_con c) + else None + in + match List.find_map try_con cons with + | Some yes -> yes + | None -> failwith "Missing constructor") | Record members -> - let _con, vals = SMT.to_con sexp in - let mk_field (l, bt) e = (l, get_ivalue gs ctys bt e) in - Record (List.map2 mk_field members vals) - + let _con, vals = SMT.to_con sexp in + let mk_field (l, bt) e = (l, get_ivalue gs ctys bt e) in + Record (List.map2 mk_field members vals) (** {1 Term to SMT} *) @@ -590,21 +515,21 @@ let translate_const s co = | Bits ((_, w), z) -> SMT.bv_k w z | Q q -> SMT.real_k q | MemByte b -> - CN_MemByte.con - ~alloc_id:(CN_AllocId.to_sexp b.alloc_id) - ~value:(SMT.bv_k CN_MemByte.width b.value) + CN_MemByte.con + ~alloc_id:(CN_AllocId.to_sexp b.alloc_id) + ~value:(SMT.bv_k CN_MemByte.width b.value) | Pointer p -> - CN_Pointer.con_aia - ~alloc_id:(CN_AllocId.to_sexp p.alloc_id) - ~addr:(SMT.bv_k CN_Pointer.width p.addr) + CN_Pointer.con_aia + ~alloc_id:(CN_AllocId.to_sexp p.alloc_id) + ~addr:(SMT.bv_k CN_Pointer.width p.addr) | Alloc_id z -> CN_AllocId.to_sexp z | Bool b -> SMT.bool_k b | Unit -> SMT.atom (CN_Tuple.name 0) | Null -> CN_Pointer.con_null | CType_const ct -> SMT.int_k (find_c_type s ct) | Default t -> - declare_bt_uninterpreted s CN_Constant.default t [] (translate_base_type t) - + declare_bt_uninterpreted s CN_Constant.default t [] + (translate_base_type t) (** Casting between bit-vector types *) let bv_cast ~to_ ~from x = @@ -621,7 +546,6 @@ let bv_cast ~to_ ~from x = | _ when from_signed -> SMT.bv_sign_extend (to_sz - from_sz) x | _ -> SMT.bv_zero_extend (to_sz - from_sz) x - (** [bv_clz rw w e] counts the leading zeroes in [e], which should be a bit-vector of width [w]. The result is a bit-vector of width [rw]. Note that this duplicates [e]. *) @@ -629,21 +553,18 @@ let bv_clz result_w = let result k = SMT.bv_k result_w k in let eq_0 w e = SMT.eq e (SMT.bv_k w Z.zero) in let rec count w e = - if w = 1 then - SMT.ite (eq_0 w e) (result Z.one) (result Z.zero) - else ( + if w = 1 then SMT.ite (eq_0 w e) (result Z.one) (result Z.zero) + else let top_w = w / 2 in let bot_w = w - top_w in let top = SMT.bv_extract (w - 1) (w - top_w) e in let bot = SMT.bv_extract (bot_w - 1) 0 e in - SMT.ite - (eq_0 top_w top) + SMT.ite (eq_0 top_w top) (SMT.bv_add (count bot_w bot) (result (Z.of_int top_w))) - (count top_w top)) + (count top_w top) in count - (** [bv_ctz rw w e] counts the tailing zeroes in [e], which should be a bit-vector of width [w]. The result is a bit-vector of width [rw]. Note that this duplicates [e]. *) @@ -651,45 +572,40 @@ let bv_ctz result_w = let result k = SMT.bv_k result_w k in let eq_0 w e = SMT.eq e (SMT.bv_k w Z.zero) in let rec count w e = - if w = 1 then - SMT.ite (eq_0 w e) (result Z.one) (result Z.zero) - else ( + if w = 1 then SMT.ite (eq_0 w e) (result Z.one) (result Z.zero) + else let top_w = w / 2 in let bot_w = w - top_w in let top = SMT.bv_extract (w - 1) (w - top_w) e in let bot = SMT.bv_extract (bot_w - 1) 0 e in - SMT.ite - (eq_0 bot_w bot) + SMT.ite (eq_0 bot_w bot) (SMT.bv_add (count top_w top) (result (Z.of_int bot_w))) - (count bot_w bot)) + (count bot_w bot) in count - (** Translate a variable to SMT. Declare if needed. *) let translate_var s name bt = let check f = Sym.Map.find_opt name f.uninterpreted in match search_frames s check with | Some e -> e | None -> - let sname = CN_Names.var_name name in - ack_command s (SMT.declare sname (translate_base_type bt)); - let e = SMT.atom sname in - let f = !(s.cur_frame) in - f.uninterpreted <- Sym.Map.add name e f.uninterpreted; - e - + let sname = CN_Names.var_name name in + ack_command s (SMT.declare sname (translate_base_type bt)); + let e = SMT.atom sname in + let f = !(s.cur_frame) in + f.uninterpreted <- Sym.Map.add name e f.uninterpreted; + e (** Translate a CN term to SMT *) let rec translate_term s iterm = let loc = IT.loc iterm in let struct_decls = s.globals.struct_decls in let maybe_name e k = - if SMT.is_atom e then - k e - else ( + if SMT.is_atom e then k e + else let x = fresh_name s CN_Names.named_expr_name in - SMT.let_ [ (x, e) ] (k (SMT.atom x))) + SMT.let_ [ (x, e) ] (k (SMT.atom x)) in let default bt = let here = Locations.other (__FUNCTION__ ^ string_of_int __LINE__) in @@ -698,394 +614,386 @@ let rec translate_term s iterm = match IT.term iterm with | Const c -> translate_const s c | Sym x -> translate_var s x (IT.basetype iterm) - | Unop (op, e1) -> - (match op with - | BW_FFS_NoSMT -> - (* NOTE: This desugaring duplicates e1 *) - let intl i = int_lit_ i (IT.bt e1) loc in - translate_term - s - (ite_ - ( eq_ (e1, intl 0) loc, - intl 0, - add_ (arith_unop BW_CTZ_NoSMT e1 loc, intl 1) loc ) - loc) - | BW_FLS_NoSMT -> - (* copying and adjusting BW_FFS_NoSMT rule *) - (* NOTE: This desugaring duplicates e1 *) - let sz = match IT.bt e1 with Bits (_sign, n) -> n | _ -> assert false in - let intl i = int_lit_ i (IT.bt e1) loc in - translate_term - s - (ite_ - ( eq_ (e1, intl 0) loc, - intl 0, - sub_ (intl sz, arith_unop BW_CLZ_NoSMT e1 loc) loc ) - loc) - | Not -> SMT.bool_not (translate_term s e1) - | Negate -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_neg (translate_term s e1) - | BT.Integer | BT.Real -> SMT.num_neg (translate_term s e1) - | _ -> failwith (__FUNCTION__ ^ ":Unop (Negate, _)")) - | BW_Compl -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_compl (translate_term s e1) - | _ -> failwith (__FUNCTION__ ^ ":Unop (BW_Compl, _)")) - | BW_CLZ_NoSMT -> - (match IT.basetype iterm with - | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_clz w w) - | _ -> failwith "solver: BW_CLZ_NoSMT: not a bitwise type") - | BW_CTZ_NoSMT -> - (match IT.basetype iterm with - | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_ctz w w) - | _ -> failwith "solver: BW_CTZ_NoSMT: not a bitwise type")) - | Binop (op, e1, e2) -> - let s1 = translate_term s e1 in - let s2 = translate_term s e2 in - (* binary uninterpreted function, same type for arguments and result. *) - let uninterp_same_type k = - let bt = IT.basetype iterm in - let smt_t = translate_base_type bt in - let f = declare_bt_uninterpreted s k bt [ smt_t; smt_t ] smt_t in - SMT.app f [ s1; s2 ] - in - (match op with - | And -> SMT.bool_and s1 s2 - | Or -> SMT.bool_or s1 s2 - | Implies -> SMT.bool_implies s1 s2 - | Add -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_add s1 s2 - | BT.Integer | BT.Real -> SMT.num_add s1 s2 - | _ -> failwith "Add") - | Sub -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_sub s1 s2 - | BT.Integer | BT.Real -> SMT.num_sub s1 s2 - | _ -> failwith "Sub") - | Mul -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_mul s1 s2 - | BT.Integer | BT.Real -> SMT.num_mul s1 s2 - | _ -> failwith "Mul") - | MulNoSMT -> uninterp_same_type CN_Constant.mul - | Div -> - (match IT.basetype iterm with - | BT.Bits (BT.Signed, _) -> SMT.bv_sdiv s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_udiv s1 s2 - | BT.Integer | BT.Real -> SMT.num_div s1 s2 - | _ -> failwith "Div") - | DivNoSMT -> uninterp_same_type CN_Constant.div - | Exp -> - (match (get_num_z e1, get_num_z e2) with - | Some z1, Some z2 when Z.fits_int z2 -> - translate_term s (num_lit_ (Z.pow z1 (Z.to_int z2)) (IT.bt e1) loc) - | _, _ -> failwith "Exp") - | ExpNoSMT -> uninterp_same_type CN_Constant.exp - | Rem -> - (match IT.basetype iterm with - | BT.Bits (BT.Signed, _) -> SMT.bv_srem s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 - | BT.Integer -> SMT.num_rem s1 s2 (* CVC5 ?? *) - | _ -> failwith "Rem") - | RemNoSMT -> uninterp_same_type CN_Constant.rem - | Mod -> - (match IT.basetype iterm with - | BT.Bits (BT.Signed, _) -> SMT.bv_smod s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 - | BT.Integer -> SMT.num_mod s1 s2 - | _ -> failwith "Mod") - | ModNoSMT -> uninterp_same_type CN_Constant.mod' - | BW_Xor -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_xor s1 s2 - | _ -> failwith "BW_Xor") - | BW_And -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_and s1 s2 - | _ -> failwith "BW_And") - | BW_Or -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_or s1 s2 - | _ -> failwith "BW_Or") - (* Shift amount should be positive? *) - | ShiftLeft -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_shl s1 s2 - | _ -> failwith "ShiftLeft") - (* Amount should be positive? *) - | ShiftRight -> - (match IT.basetype iterm with - | BT.Bits (BT.Signed, _) -> SMT.bv_ashr s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_lshr s1 s2 - | _ -> failwith "ShiftRight") - | LT -> - (match IT.basetype e1 with - | BT.Bits (BT.Signed, _) -> SMT.bv_slt s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_ult s1 s2 - | BT.Integer | BT.Real -> SMT.num_lt s1 s2 - | _ -> failwith "LT") - | LE -> - (match IT.basetype e1 with - | BT.Bits (BT.Signed, _) -> SMT.bv_sleq s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_uleq s1 s2 - | BT.Integer | BT.Real -> SMT.num_leq s1 s2 - | ty -> - Pp.print stdout (!^"LE" ^^^ BT.pp ty); - failwith "LE") - (* NOTE: duplicates terms *) - | Min -> translate_term s (ite_ (le_ (e1, e2) loc, e1, e2) loc) - (* NOTE: duplicates terms *) - | Max -> translate_term s (ite_ (ge_ (e1, e2) loc, e1, e2) loc) - | EQ -> SMT.eq s1 s2 - | LTPointer -> - let uintptr_cast = cast_ Memory.uintptr_bt in - translate_term s (lt_ (uintptr_cast e1 loc, uintptr_cast e2 loc) loc) - | LEPointer -> - let uintptr_cast = cast_ Memory.uintptr_bt in - translate_term s (le_ (uintptr_cast e1 loc, uintptr_cast e2 loc) loc) - | SetUnion -> SMT.set_union s.smt_solver.config.exts s1 s2 - | SetIntersection -> SMT.set_intersection s.smt_solver.config.exts s1 s2 - | SetDifference -> SMT.set_difference s.smt_solver.config.exts s1 s2 - | SetMember -> SMT.set_member s.smt_solver.config.exts s1 s2 - | Subset -> SMT.set_subset s.smt_solver.config.exts s1 s2) + | Unop (op, e1) -> ( + match op with + | BW_FFS_NoSMT -> + (* NOTE: This desugaring duplicates e1 *) + let intl i = int_lit_ i (IT.bt e1) loc in + translate_term s + (ite_ + ( eq_ (e1, intl 0) loc, + intl 0, + add_ (arith_unop BW_CTZ_NoSMT e1 loc, intl 1) loc ) + loc) + | BW_FLS_NoSMT -> + (* copying and adjusting BW_FFS_NoSMT rule *) + (* NOTE: This desugaring duplicates e1 *) + let sz = + match IT.bt e1 with Bits (_sign, n) -> n | _ -> assert false + in + let intl i = int_lit_ i (IT.bt e1) loc in + translate_term s + (ite_ + ( eq_ (e1, intl 0) loc, + intl 0, + sub_ (intl sz, arith_unop BW_CLZ_NoSMT e1 loc) loc ) + loc) + | Not -> SMT.bool_not (translate_term s e1) + | Negate -> ( + match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_neg (translate_term s e1) + | BT.Integer | BT.Real -> SMT.num_neg (translate_term s e1) + | _ -> failwith (__FUNCTION__ ^ ":Unop (Negate, _)")) + | BW_Compl -> ( + match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_compl (translate_term s e1) + | _ -> failwith (__FUNCTION__ ^ ":Unop (BW_Compl, _)")) + | BW_CLZ_NoSMT -> ( + match IT.basetype iterm with + | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_clz w w) + | _ -> failwith "solver: BW_CLZ_NoSMT: not a bitwise type") + | BW_CTZ_NoSMT -> ( + match IT.basetype iterm with + | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_ctz w w) + | _ -> failwith "solver: BW_CTZ_NoSMT: not a bitwise type")) + | Binop (op, e1, e2) -> ( + let s1 = translate_term s e1 in + let s2 = translate_term s e2 in + (* binary uninterpreted function, same type for arguments and result. *) + let uninterp_same_type k = + let bt = IT.basetype iterm in + let smt_t = translate_base_type bt in + let f = declare_bt_uninterpreted s k bt [ smt_t; smt_t ] smt_t in + SMT.app f [ s1; s2 ] + in + match op with + | And -> SMT.bool_and s1 s2 + | Or -> SMT.bool_or s1 s2 + | Implies -> SMT.bool_implies s1 s2 + | Add -> ( + match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_add s1 s2 + | BT.Integer | BT.Real -> SMT.num_add s1 s2 + | _ -> failwith "Add") + | Sub -> ( + match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_sub s1 s2 + | BT.Integer | BT.Real -> SMT.num_sub s1 s2 + | _ -> failwith "Sub") + | Mul -> ( + match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_mul s1 s2 + | BT.Integer | BT.Real -> SMT.num_mul s1 s2 + | _ -> failwith "Mul") + | MulNoSMT -> uninterp_same_type CN_Constant.mul + | Div -> ( + match IT.basetype iterm with + | BT.Bits (BT.Signed, _) -> SMT.bv_sdiv s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_udiv s1 s2 + | BT.Integer | BT.Real -> SMT.num_div s1 s2 + | _ -> failwith "Div") + | DivNoSMT -> uninterp_same_type CN_Constant.div + | Exp -> ( + match (get_num_z e1, get_num_z e2) with + | Some z1, Some z2 when Z.fits_int z2 -> + translate_term s + (num_lit_ (Z.pow z1 (Z.to_int z2)) (IT.bt e1) loc) + | _, _ -> failwith "Exp") + | ExpNoSMT -> uninterp_same_type CN_Constant.exp + | Rem -> ( + match IT.basetype iterm with + | BT.Bits (BT.Signed, _) -> SMT.bv_srem s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 + | BT.Integer -> SMT.num_rem s1 s2 (* CVC5 ?? *) + | _ -> failwith "Rem") + | RemNoSMT -> uninterp_same_type CN_Constant.rem + | Mod -> ( + match IT.basetype iterm with + | BT.Bits (BT.Signed, _) -> SMT.bv_smod s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 + | BT.Integer -> SMT.num_mod s1 s2 + | _ -> failwith "Mod") + | ModNoSMT -> uninterp_same_type CN_Constant.mod' + | BW_Xor -> ( + match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_xor s1 s2 + | _ -> failwith "BW_Xor") + | BW_And -> ( + match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_and s1 s2 + | _ -> failwith "BW_And") + | BW_Or -> ( + match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_or s1 s2 + | _ -> failwith "BW_Or") + (* Shift amount should be positive? *) + | ShiftLeft -> ( + match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_shl s1 s2 + | _ -> failwith "ShiftLeft") + (* Amount should be positive? *) + | ShiftRight -> ( + match IT.basetype iterm with + | BT.Bits (BT.Signed, _) -> SMT.bv_ashr s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_lshr s1 s2 + | _ -> failwith "ShiftRight") + | LT -> ( + match IT.basetype e1 with + | BT.Bits (BT.Signed, _) -> SMT.bv_slt s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_ult s1 s2 + | BT.Integer | BT.Real -> SMT.num_lt s1 s2 + | _ -> failwith "LT") + | LE -> ( + match IT.basetype e1 with + | BT.Bits (BT.Signed, _) -> SMT.bv_sleq s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_uleq s1 s2 + | BT.Integer | BT.Real -> SMT.num_leq s1 s2 + | ty -> + Pp.print stdout (!^"LE" ^^^ BT.pp ty); + failwith "LE") + (* NOTE: duplicates terms *) + | Min -> translate_term s (ite_ (le_ (e1, e2) loc, e1, e2) loc) + (* NOTE: duplicates terms *) + | Max -> translate_term s (ite_ (ge_ (e1, e2) loc, e1, e2) loc) + | EQ -> SMT.eq s1 s2 + | LTPointer -> + let uintptr_cast = cast_ Memory.uintptr_bt in + translate_term s (lt_ (uintptr_cast e1 loc, uintptr_cast e2 loc) loc) + | LEPointer -> + let uintptr_cast = cast_ Memory.uintptr_bt in + translate_term s (le_ (uintptr_cast e1 loc, uintptr_cast e2 loc) loc) + | SetUnion -> SMT.set_union s.smt_solver.config.exts s1 s2 + | SetIntersection -> SMT.set_intersection s.smt_solver.config.exts s1 s2 + | SetDifference -> SMT.set_difference s.smt_solver.config.exts s1 s2 + | SetMember -> SMT.set_member s.smt_solver.config.exts s1 s2 + | Subset -> SMT.set_subset s.smt_solver.config.exts s1 s2) | ITE (b, e1, e2) -> - SMT.ite (translate_term s b) (translate_term s e1) (translate_term s e2) + SMT.ite (translate_term s b) (translate_term s e1) (translate_term s e2) | EachI ((i1, (x, bt), i2), t) -> - let rec aux i = - if i <= i2 then ( - let su = make_subst [ (x, num_lit_ (Z.of_int i) bt loc) ] in - let t1 = IT.subst su t in - if i = i2 then - t1 - else - IT.and2_ (t1, aux (i + 1)) loc) - else - failwith "EachI" - in - if i1 > i2 then - translate_term s (IT.bool_ true loc) - else - translate_term s (aux i1) + let rec aux i = + if i <= i2 then + let su = make_subst [ (x, num_lit_ (Z.of_int i) bt loc) ] in + let t1 = IT.subst su t in + if i = i2 then t1 else IT.and2_ (t1, aux (i + 1)) loc + else failwith "EachI" + in + if i1 > i2 then translate_term s (IT.bool_ true loc) + else translate_term s (aux i1) (* Tuples *) | Tuple es -> CN_Tuple.con (List.map (translate_term s) es) - | NthTuple (n, e1) -> - (match IT.basetype e1 with - | Tuple ts -> CN_Tuple.get (List.length ts) n (translate_term s e1) - | _ -> failwith "NthTuple: not a tuple") + | NthTuple (n, e1) -> ( + match IT.basetype e1 with + | Tuple ts -> CN_Tuple.get (List.length ts) n (translate_term s e1) + | _ -> failwith "NthTuple: not a tuple") (* Structs *) (* assumes that the fileds are in the correct order *) | Struct (tag, fields) -> - let con = CN_Names.struct_con_name tag in - let field (_, e) = translate_term s e in - SMT.app_ con (List.map field fields) + let con = CN_Names.struct_con_name tag in + let field (_, e) = translate_term s e in + SMT.app_ con (List.map field fields) | StructMember (e1, f) -> - SMT.app_ (CN_Names.struct_field_name f) [ translate_term s e1 ] + SMT.app_ (CN_Names.struct_field_name f) [ translate_term s e1 ] | StructUpdate ((t, member), v) -> - let tag = BT.struct_bt (IT.bt t) in - let layout = Sym.Map.find (struct_bt (IT.bt t)) struct_decls in - let members = Memory.member_types layout in - let str = - List.map - (fun (member', sct) -> - let value = - if Id.equal member member' then - v - else - member_ ~member_bt:(Memory.bt_of_sct sct) (t, member') loc - in - (member', value)) - members - in - translate_term s (struct_ (tag, str) loc) + let tag = BT.struct_bt (IT.bt t) in + let layout = Sym.Map.find (struct_bt (IT.bt t)) struct_decls in + let members = Memory.member_types layout in + let str = + List.map + (fun (member', sct) -> + let value = + if Id.equal member member' then v + else member_ ~member_bt:(Memory.bt_of_sct sct) (t, member') loc + in + (member', value)) + members + in + translate_term s (struct_ (tag, str) loc) | OffsetOf (tag, member) -> - let decl = Sym.Map.find tag struct_decls in - let v = Option.get (Memory.member_offset decl member) in - translate_term s (int_lit_ v (IT.basetype iterm) loc) + let decl = Sym.Map.find tag struct_decls in + let v = Option.get (Memory.member_offset decl member) in + translate_term s (int_lit_ v (IT.basetype iterm) loc) (* Records *) | Record members -> - let field (_, e) = translate_term s e in - CN_Tuple.con (List.map field members) - | RecordMember (e1, f) -> - (match IT.basetype e1 with - | Record members -> - let check (x, _) = Id.equal f x in - let arity = List.length members in - (match List.find_index check members with - | Some n -> CN_Tuple.get arity n (translate_term s e1) - | None -> failwith "Missing record field.") - | _ -> failwith "RecordMemmber") + let field (_, e) = translate_term s e in + CN_Tuple.con (List.map field members) + | RecordMember (e1, f) -> ( + match IT.basetype e1 with + | Record members -> ( + let check (x, _) = Id.equal f x in + let arity = List.length members in + match List.find_index check members with + | Some n -> CN_Tuple.get arity n (translate_term s e1) + | None -> failwith "Missing record field.") + | _ -> failwith "RecordMemmber") | RecordUpdate ((t, member), v) -> - let members = BT.record_bt (IT.bt t) in - let str = - List.map - (fun (member', bt) -> - let value = - if Id.equal member member' then - v - else - IT (RecordMember (t, member'), bt, loc) - in - (member', value)) - members - in - translate_term s (IT (Record str, IT.bt t, loc)) + let members = BT.record_bt (IT.bt t) in + let str = + List.map + (fun (member', bt) -> + let value = + if Id.equal member member' then v + else IT (RecordMember (t, member'), bt, loc) + in + (member', value)) + members + in + translate_term s (IT (Record str, IT.bt t, loc)) | MemberShift (t, tag, member) -> - CN_Pointer.ptr_shift - ~ptr:(translate_term s t) - ~null_case:(default (Loc ())) - ~offset:(translate_term s (IT (OffsetOf (tag, member), Memory.uintptr_bt, loc))) + CN_Pointer.ptr_shift ~ptr:(translate_term s t) + ~null_case:(default (Loc ())) + ~offset: + (translate_term s + (IT (OffsetOf (tag, member), Memory.uintptr_bt, loc))) | ArrayShift { base; ct; index } -> - CN_Pointer.ptr_shift - ~ptr:(translate_term s base) - ~null_case:(default (Loc ())) - ~offset: - (let el_size = int_lit_ (Memory.size_of_ctype ct) Memory.uintptr_bt loc in - (* locations don't matter here - we are translating straight away *) - let ix = - if BT.equal (IT.bt index) Memory.uintptr_bt then - index - else - cast_ Memory.uintptr_bt index loc - in - translate_term s (mul_ (el_size, ix) loc)) + CN_Pointer.ptr_shift ~ptr:(translate_term s base) + ~null_case:(default (Loc ())) + ~offset: + (let el_size = + int_lit_ (Memory.size_of_ctype ct) Memory.uintptr_bt loc + in + (* locations don't matter here - we are translating straight away *) + let ix = + if BT.equal (IT.bt index) Memory.uintptr_bt then index + else cast_ Memory.uintptr_bt index loc + in + translate_term s (mul_ (el_size, ix) loc)) | CopyAllocId { addr; loc } -> - CN_Pointer.copy_alloc_id - ~ptr:(translate_term s loc) - ~null_case:(default (Loc ())) - ~addr:(translate_term s addr) - | HasAllocId loc -> SMT.is_con CN_Pointer.alloc_id_addr_name (translate_term s loc) + CN_Pointer.copy_alloc_id ~ptr:(translate_term s loc) + ~null_case:(default (Loc ())) ~addr:(translate_term s addr) + | HasAllocId loc -> + SMT.is_con CN_Pointer.alloc_id_addr_name (translate_term s loc) (* Lists *) | Nil bt -> CN_List.nil (translate_base_type bt) | Cons (e1, e2) -> CN_List.cons (translate_term s e1) (translate_term s e2) | Head e1 -> - maybe_name (translate_term s e1) (fun xs -> - CN_List.head xs (translate_term s (default_ (IT.basetype iterm) loc))) + maybe_name (translate_term s e1) (fun xs -> + CN_List.head xs (translate_term s (default_ (IT.basetype iterm) loc))) | Tail e1 -> - maybe_name (translate_term s e1) (fun xs -> - CN_List.tail xs (translate_term s (default_ (IT.basetype iterm) loc))) + maybe_name (translate_term s e1) (fun xs -> + CN_List.tail xs (translate_term s (default_ (IT.basetype iterm) loc))) | NthList (x, y, z) -> - let arg x = (translate_base_type (IT.basetype x), translate_term s x) in - let arg_ts, args = List.split (List.map arg [ x; y; z ]) in - let bt = IT.basetype iterm in - let res_t = translate_base_type bt in - let f = declare_bt_uninterpreted s CN_Constant.nth_list bt arg_ts res_t in - SMT.app f args + let arg x = (translate_base_type (IT.basetype x), translate_term s x) in + let arg_ts, args = List.split (List.map arg [ x; y; z ]) in + let bt = IT.basetype iterm in + let res_t = translate_base_type bt in + let f = declare_bt_uninterpreted s CN_Constant.nth_list bt arg_ts res_t in + SMT.app f args | ArrayToList (x, y, z) -> - let arg x = (translate_base_type (IT.basetype x), translate_term s x) in - let arg_ts, args = List.split (List.map arg [ x; y; z ]) in - let bt = IT.basetype iterm in - let res_t = translate_base_type bt in - let f = declare_bt_uninterpreted s CN_Constant.array_to_list bt arg_ts res_t in - SMT.app f args + let arg x = (translate_base_type (IT.basetype x), translate_term s x) in + let arg_ts, args = List.split (List.map arg [ x; y; z ]) in + let bt = IT.basetype iterm in + let res_t = translate_base_type bt in + let f = + declare_bt_uninterpreted s CN_Constant.array_to_list bt arg_ts res_t + in + SMT.app f args | SizeOf ct -> - translate_term s (IT.int_lit_ (Memory.size_of_ctype ct) (IT.basetype iterm) loc) - | Representable (ct, t) -> translate_term s (representable struct_decls ct t loc) + translate_term s + (IT.int_lit_ (Memory.size_of_ctype ct) (IT.basetype iterm) loc) + | Representable (ct, t) -> + translate_term s (representable struct_decls ct t loc) | Good (ct, t) -> translate_term s (good_value struct_decls ct t loc) | Aligned t -> - let addr = addr_ t.t loc in - assert (BT.equal (IT.bt addr) (IT.bt t.align)); - translate_term s (divisible_ (addr, t.align) loc) + let addr = addr_ t.t loc in + assert (BT.equal (IT.bt addr) (IT.bt t.align)); + translate_term s (divisible_ (addr, t.align) loc) (* Maps *) | MapConst (bt, e1) -> - let kt = translate_base_type bt in - let vt = translate_base_type (IT.basetype e1) in - SMT.arr_const kt vt (translate_term s e1) + let kt = translate_base_type bt in + let vt = translate_base_type (IT.basetype e1) in + SMT.arr_const kt vt (translate_term s e1) | MapSet (mp, k, v) -> - SMT.arr_store (translate_term s mp) (translate_term s k) (translate_term s v) + SMT.arr_store (translate_term s mp) (translate_term s k) + (translate_term s v) | MapGet (mp, k) -> SMT.arr_select (translate_term s mp) (translate_term s k) | MapDef _ -> failwith "MapDef" - | Apply (name, args) -> - let def = Option.get (get_logical_function_def s.globals name) in - (match def.body with - | Def body -> translate_term s (Definition.Function.open_ def.args body args) - | _ -> - let do_arg arg = translate_base_type (IT.basetype arg) in - let args_ts = List.map do_arg args in - let res_t = translate_base_type def.return_bt in - let fu = declare_uninterpreted s name args_ts res_t in - SMT.app fu (List.map (translate_term s) args)) + | Apply (name, args) -> ( + let def = Option.get (get_logical_function_def s.globals name) in + match def.body with + | Def body -> + translate_term s (Definition.Function.open_ def.args body args) + | _ -> + let do_arg arg = translate_base_type (IT.basetype arg) in + let args_ts = List.map do_arg args in + let res_t = translate_base_type def.return_bt in + let fu = declare_uninterpreted s name args_ts res_t in + SMT.app fu (List.map (translate_term s) args)) | Let ((x, e1), e2) -> - let se1 = translate_term s e1 in - let name = CN_Names.var_name x in - let se2 = translate_term s e2 in - SMT.let_ [ (name, se1) ] se2 + let se1 = translate_term s e1 in + let name = CN_Names.var_name x in + let se2 = translate_term s e2 in + SMT.let_ [ (name, se1) ] se2 (* Datatypes *) (* Assumes the fields are in the correct order *) | Constructor (c, fields) -> - let con = CN_Names.datatype_con_name c in - let field (_, e) = translate_term s e in - SMT.app_ con (List.map field fields) - (* CN supports nested patterns, while SMTLIB does not, so we compile patterns to a - optional predicate, and defined variables. *) + let con = CN_Names.datatype_con_name c in + let field (_, e) = translate_term s e in + SMT.app_ con (List.map field fields) + (* CN supports nested patterns, while SMTLIB does not, so we compile patterns to a + optional predicate, and defined variables. *) | Match (e1, alts) -> - let rec match_pat v (Pat (pat, _, _)) = - match pat with - | PSym x -> (None, [ (CN_Names.var_name x, v) ]) - | PWild -> (None, []) - | PConstructor (c, fs) -> - let field (f, nested) = - let new_v = SMT.app_ (CN_Names.datatype_field_name f) [ v ] in - match_pat new_v nested - in - let conds, defs = List.split (List.map field fs) in - let nested_cond = SMT.bool_ands (List.filter_map (fun x -> x) conds) in - let cname = CN_Names.datatype_con_name c in - let cond = SMT.bool_and (SMT.is_con cname v) nested_cond in - (Some cond, List.concat defs) - in - let rec do_alts v alts = - match alts with - | [] -> translate_term s (default_ (IT.basetype iterm) loc) - | (pat, rhs) :: more -> - let mb_cond, binds = match_pat v pat in - let k = SMT.let_ binds (translate_term s rhs) in - (match mb_cond with Some cond -> SMT.ite cond k (do_alts v more) | None -> k) - in - let x = fresh_name s "match" in - SMT.let_ [ (x, translate_term s e1) ] (do_alts (SMT.atom x) alts) + let rec match_pat v (Pat (pat, _, _)) = + match pat with + | PSym x -> (None, [ (CN_Names.var_name x, v) ]) + | PWild -> (None, []) + | PConstructor (c, fs) -> + let field (f, nested) = + let new_v = SMT.app_ (CN_Names.datatype_field_name f) [ v ] in + match_pat new_v nested + in + let conds, defs = List.split (List.map field fs) in + let nested_cond = + SMT.bool_ands (List.filter_map (fun x -> x) conds) + in + let cname = CN_Names.datatype_con_name c in + let cond = SMT.bool_and (SMT.is_con cname v) nested_cond in + (Some cond, List.concat defs) + in + let rec do_alts v alts = + match alts with + | [] -> translate_term s (default_ (IT.basetype iterm) loc) + | (pat, rhs) :: more -> ( + let mb_cond, binds = match_pat v pat in + let k = SMT.let_ binds (translate_term s rhs) in + match mb_cond with + | Some cond -> SMT.ite cond k (do_alts v more) + | None -> k) + in + let x = fresh_name s "match" in + SMT.let_ [ (x, translate_term s e1) ] (do_alts (SMT.atom x) alts) (* Casts *) | WrapI (ity, arg) -> - bv_cast - ~to_:(Memory.bt_of_sct (Sctypes.Integer ity)) - ~from:(IT.bt arg) - (translate_term s arg) - | Cast (cbt, t) -> - let smt_term = translate_term s t in - (match (IT.bt t, cbt) with - | Bits _, Loc () -> - let addr = - if BT.equal (IT.bt t) Memory.uintptr_bt then - smt_term - else - bv_cast ~to_:Memory.uintptr_bt ~from:(IT.bt t) smt_term - in - CN_Pointer.bits_to_ptr ~bits:addr ~alloc_id:(default Alloc_id) - | Loc (), Bits _ -> - let maybe_cast x = - if BT.equal cbt Memory.uintptr_bt then - x - else - bv_cast ~to_:cbt ~from:Memory.uintptr_bt x - in - maybe_cast (CN_Pointer.addr_of ~ptr:smt_term) - | Loc (), Alloc_id -> - CN_Pointer.alloc_id_of ~ptr:smt_term ~null_case:(default Alloc_id) - | MemByte, Bits _ -> - let maybe_cast x = - if BT.equal cbt (BT.Bits (Unsigned, 8)) then - x - else - bv_cast ~to_:cbt ~from:(BT.Bits (Unsigned, 8)) x - in - maybe_cast (SMT.app_ CN_MemByte.value_name [ smt_term ]) - | MemByte, Alloc_id -> SMT.app_ CN_MemByte.alloc_id_name [ smt_term ] - | Real, Integer -> SMT.real_to_int smt_term - | Integer, Real -> SMT.int_to_real smt_term - | Bits _, Bits _ -> bv_cast ~to_:cbt ~from:(IT.bt t) smt_term - | _ -> assert false) - + bv_cast + ~to_:(Memory.bt_of_sct (Sctypes.Integer ity)) + ~from:(IT.bt arg) (translate_term s arg) + | Cast (cbt, t) -> ( + let smt_term = translate_term s t in + match (IT.bt t, cbt) with + | Bits _, Loc () -> + let addr = + if BT.equal (IT.bt t) Memory.uintptr_bt then smt_term + else bv_cast ~to_:Memory.uintptr_bt ~from:(IT.bt t) smt_term + in + CN_Pointer.bits_to_ptr ~bits:addr ~alloc_id:(default Alloc_id) + | Loc (), Bits _ -> + let maybe_cast x = + if BT.equal cbt Memory.uintptr_bt then x + else bv_cast ~to_:cbt ~from:Memory.uintptr_bt x + in + maybe_cast (CN_Pointer.addr_of ~ptr:smt_term) + | Loc (), Alloc_id -> + CN_Pointer.alloc_id_of ~ptr:smt_term ~null_case:(default Alloc_id) + | MemByte, Bits _ -> + let maybe_cast x = + if BT.equal cbt (BT.Bits (Unsigned, 8)) then x + else bv_cast ~to_:cbt ~from:(BT.Bits (Unsigned, 8)) x + in + maybe_cast (SMT.app_ CN_MemByte.value_name [ smt_term ]) + | MemByte, Alloc_id -> SMT.app_ CN_MemByte.alloc_id_name [ smt_term ] + | Real, Integer -> SMT.real_to_int smt_term + | Integer, Real -> SMT.int_to_real smt_term + | Bits _, Bits _ -> bv_cast ~to_:cbt ~from:(IT.bt t) smt_term + | _ -> assert false) (** Add an assertion. Quantified predicates are ignored. *) let add_assumption solver global lc = @@ -1094,13 +1002,12 @@ let add_assumption solver global lc = | T it -> ack_command solver (SMT.assume (translate_term s1 it)) | Forall _ -> () - +type reduction = { + expr : SMT.sexp; (* translation of `it` *) + qs : (Sym.t * BT.t) list; (* quantifier instantiation *) + extra : SMT.sexp list (* additional assumptions *); +} (** Goals are translated to this type *) -type reduction = - { expr : SMT.sexp; (* translation of `it` *) - qs : (Sym.t * BT.t) list; (* quantifier instantiation *) - extra : SMT.sexp list (* additional assumptions *) - } let translate_goal solver assumptions lc = let here = Locations.other __FUNCTION__ in @@ -1108,35 +1015,37 @@ let translate_goal solver assumptions lc = match lc with | T it -> { expr = translate_term solver it; qs = []; extra = [] } | Forall ((s, bt), it) -> - let v_s, v = IT.fresh_same bt s here in - let it = IT.subst (make_subst [ (s, v) ]) it in - { expr = translate_term solver it; qs = [ (v_s, bt) ]; extra = [] } + let v_s, v = IT.fresh_same bt s here in + let it = IT.subst (make_subst [ (s, v) ]) it in + { expr = translate_term solver it; qs = [ (v_s, bt) ]; extra = [] } in let add_asmps acc0 (s, bt) = let v = sym_ (s, bt, here) in let check_asmp lc acc = match lc with | Forall ((s', bt'), it') when BT.equal bt bt' -> - let new_asmp = IT.subst (make_subst [ (s', v) ]) it' in - translate_term solver new_asmp :: acc + let new_asmp = IT.subst (make_subst [ (s', v) ]) it' in + translate_term solver new_asmp :: acc | _ -> acc in LC.Set.fold check_asmp assumptions acc0 in { instantiated with extra = List.fold_left add_asmps [] instantiated.qs } - (* as similarly suggested by Robbert *) let shortcut simp_ctxt lc = let lc = Simplify.LogicalConstraints.simp simp_ctxt lc in - match lc with LC.T (IT (Const (Bool true), _, _)) -> `True | _ -> `No_shortcut lc - + match lc with + | LC.T (IT (Const (Bool true), _, _)) -> `True + | _ -> `No_shortcut lc (** {1 Solver Initialization} *) (** Declare a group of (possibly) mutually recursive datatypes *) let declare_datatype_group s names = - let mk_con_field (l, t) = (CN_Names.datatype_field_name l, translate_base_type t) in + let mk_con_field (l, t) = + (CN_Names.datatype_field_name l, translate_base_type t) + in let mk_con c = let ci = Sym.Map.find c s.globals.datatype_constrs in (CN_Names.datatype_con_name c, List.map mk_con_field ci.params) @@ -1148,21 +1057,19 @@ let declare_datatype_group s names = in ack_command s (SMT.declare_datatypes (List.map to_smt names)) - (** Declare a struct type and all struct types that it depends on. The `done_struct` keeps track of which structs we've already declared. *) let rec declare_struct s done_struct name decl = let mp = !done_struct in - if Sym.Set.mem name mp then - () + if Sym.Set.mem name mp then () else ( done_struct := Sym.Set.add name mp; let mk_field (l, t) = let rec declare_nested ty = match ty with | Struct name' -> - let decl = Sym.Map.find name' s.globals.struct_decls in - declare_struct s done_struct name' decl + let decl = Sym.Map.find name' s.globals.struct_decls in + declare_struct s done_struct name' decl | Map (_, el) -> declare_nested el | _ -> () in @@ -1170,18 +1077,18 @@ let rec declare_struct s done_struct name decl = declare_nested ty; (CN_Names.struct_field_name l, translate_base_type ty) in - let mk_piece (x : Memory.struct_piece) = Option.map mk_field x.member_or_padding in - ack_command - s + let mk_piece (x : Memory.struct_piece) = + Option.map mk_field x.member_or_padding + in + ack_command s (SMT.declare_datatype (CN_Names.struct_name name) [] [ (CN_Names.struct_con_name name, List.filter_map mk_piece decl) ])) - (** Declare various types always available to the solver. *) let declare_solver_basics s = - for arity = 0 to 8 do + for arity = 0 to 15 do CN_Tuple.declare s arity done; CN_List.declare s; @@ -1193,7 +1100,6 @@ let declare_solver_basics s = Sym.Map.iter (declare_struct s done_structs) s.globals.struct_decls; List.iter (declare_datatype_group s) (Option.get s.globals.datatype_order) - (* Logging *) module Logger = struct @@ -1203,7 +1109,6 @@ module Logger = struct let include_solver_responses = ref false let dir = ref (None : string option) - let log_counter = ref 0 (* Names of SMT files *) (** Pick a logger based on the above settings *) @@ -1215,34 +1120,39 @@ module Logger = struct match !dir with | Some dir -> dir | None -> - let nm = Printf.sprintf "cn_%.3f" (Unix.gettimeofday ()) in - let d = Filename.concat (Filename.get_temp_dir_name ()) nm in - dir := Some d; - d + let nm = Printf.sprintf "cn_%.3f" (Unix.gettimeofday ()) in + let d = Filename.concat (Filename.get_temp_dir_name ()) nm in + dir := Some d; + d in if not (Sys.file_exists dir) then Sys.mkdir dir 0o700 else (); - open_out (Filename.concat dir (prefix ^ suf ^ string_of_int log_id ^ ".smt")) + open_out + (Filename.concat dir (prefix ^ suf ^ string_of_int log_id ^ ".smt")) in - if !to_file then ( + if !to_file then let out = get_file "_send_" in if !include_solver_responses then - { SMT.send = Printf.fprintf out "[->] %s\n%!"; + { + SMT.send = Printf.fprintf out "[->] %s\n%!"; SMT.receive = Printf.fprintf out "[<-] %s\n%!"; - SMT.stop = (fun _ -> close_out out) + SMT.stop = (fun _ -> close_out out); } else - { SMT.send = Printf.fprintf out "%s\n%!"; + { + SMT.send = Printf.fprintf out "%s\n%!"; SMT.receive = (fun _ -> ()); - SMT.stop = (fun _ -> close_out out) - }) + SMT.stop = (fun _ -> close_out out); + } else - { SMT.send = (fun _ -> ()); SMT.receive = (fun _ -> ()); SMT.stop = (fun _ -> ()) } + { + SMT.send = (fun _ -> ()); + SMT.receive = (fun _ -> ()); + SMT.stop = (fun _ -> ()); + } end let solver_path = ref (None : string option) - let solver_type = ref (None : SMT.solver_extensions option) - let solver_flags = ref (None : string list option) (** Make a new solver instance *) @@ -1250,53 +1160,55 @@ let make globals = let cfg = ref (match !solver_type with - | Some t -> - (match t with + | Some t -> ( + match t with | SMT.Z3 -> SMT.z3 | SMT.CVC5 -> SMT.cvc5 | SMT.Other -> failwith "Unsupported solver.") - | None -> - (match !solver_path with + | None -> ( + match !solver_path with | None -> SMT.z3 - | Some path -> - (match Filename.basename path with - | "z3" -> SMT.z3 - | "cvc5" -> SMT.cvc5 - | _ -> failwith "Please specify solver type"))) + | Some path -> ( + match Filename.basename path with + | "z3" -> SMT.z3 + | "cvc5" -> SMT.cvc5 + | _ -> failwith "Please specify solver type"))) in - (match !solver_path with Some path -> cfg := { !cfg with SMT.exe = path } | None -> ()); - (match !solver_flags with Some opts -> cfg := { !cfg with SMT.opts } | None -> ()); - cfg - := { !cfg with - log = - Logger.make - (match !cfg.exts with - | SMT.Z3 -> "z3" - | SMT.CVC5 -> "cvc5" - | SMT.Other -> "other") - }; + (match !solver_path with + | Some path -> cfg := { !cfg with SMT.exe = path } + | None -> ()); + (match !solver_flags with + | Some opts -> cfg := { !cfg with SMT.opts } + | None -> ()); + cfg := + { + !cfg with + log = + Logger.make + (match !cfg.exts with + | SMT.Z3 -> "z3" + | SMT.CVC5 -> "cvc5" + | SMT.Other -> "other"); + }; let s = - { smt_solver = SMT.new_solver !cfg; + { + smt_solver = SMT.new_solver !cfg; cur_frame = ref (empty_solver_frame ()); prev_frames = ref []; name_seed = ref 0; - globals + globals; } in declare_solver_basics s; s - (* ---------------------------------------------------------------------------*) (* GLOBAL STATE: Models *) (* ---------------------------------------------------------------------------*) type model = int - type model_fn = IT.t -> IT.t option - type model_with_q = model * (Sym.t * BaseTypes.t) list - type model_table = (model, model_fn) Hashtbl.t let models_tbl : model_table = Hashtbl.create 1 @@ -1306,14 +1218,12 @@ let empty_model = Hashtbl.add models_tbl 0 model; 0 - -type model_state = - | Model of model_with_q - | No_model +type model_state = Model of model_with_q | No_model let model_state = ref No_model -let model () = match !model_state with No_model -> assert false | Model mo -> mo +let model () = + match !model_state with No_model -> assert false | Model mo -> mo (** Evaluate terms in the context of a model computed by the solver. *) let model_evaluator = @@ -1330,51 +1240,52 @@ let model_evaluator = match SMT.to_list mo with | None -> failwith "model is an atom" | Some defs -> - let scfg = solver.smt_solver.config in - let cfg = { scfg with log = Logger.make "model" } in - let smt_solver, new_solver = - match !model_evaluator_solver with - | Some smt_solver -> (smt_solver, false) - | None -> - let s = SMT.new_solver cfg in - model_evaluator_solver := Some s; - (s, true) - in - let model_id = new_model_id () in - let gs = solver.globals in - let evaluator = - { smt_solver; - cur_frame = ref (empty_solver_frame ()); - prev_frames = - ref - (List.map copy_solver_frame (!(solver.cur_frame) :: !(solver.prev_frames))) - (* We keep the prev_frames because things that were declared, would now be - defined by the model. Also, we need the infromation about the C type - mapping. *); - name_seed = solver.name_seed; - globals = gs - } - in - if new_solver then ( - declare_solver_basics evaluator; - push evaluator); - let model_fn e = - if not (!currently_loaded_model = model_id) then ( - currently_loaded_model := model_id; - pop evaluator 1; - push evaluator; - List.iter (debug_ack_command evaluator) defs); - let inp = translate_term evaluator e in - match SMT.check smt_solver with - | SMT.Sat -> - let res = SMT.get_expr smt_solver inp in - let ctys = get_ctype_table evaluator in - Some (get_ivalue gs ctys (basetype e) (SMT.no_let res)) - | _ -> None - in - Hashtbl.add models_tbl model_id model_fn; - model_id - + let scfg = solver.smt_solver.config in + let cfg = { scfg with log = Logger.make "model" } in + let smt_solver, new_solver = + match !model_evaluator_solver with + | Some smt_solver -> (smt_solver, false) + | None -> + let s = SMT.new_solver cfg in + model_evaluator_solver := Some s; + (s, true) + in + let model_id = new_model_id () in + let gs = solver.globals in + let evaluator = + { + smt_solver; + cur_frame = ref (empty_solver_frame ()); + prev_frames = + ref + (List.map copy_solver_frame + (!(solver.cur_frame) :: !(solver.prev_frames))) + (* We keep the prev_frames because things that were declared, would now be + defined by the model. Also, we need the infromation about the C type + mapping. *); + name_seed = solver.name_seed; + globals = gs; + } + in + if new_solver then ( + declare_solver_basics evaluator; + push evaluator); + let model_fn e = + if not (!currently_loaded_model = model_id) then ( + currently_loaded_model := model_id; + pop evaluator 1; + push evaluator; + List.iter (debug_ack_command evaluator) defs); + let inp = translate_term evaluator e in + match SMT.check smt_solver with + | SMT.Sat -> + let res = SMT.get_expr smt_solver inp in + let ctys = get_ctype_table evaluator in + Some (get_ivalue gs ctys (basetype e) (SMT.no_let res)) + | _ -> None + in + Hashtbl.add models_tbl model_id model_fn; + model_id (* ---------------------------------------------------------------------------*) @@ -1389,30 +1300,29 @@ let provable ~loc ~solver ~global ~assumptions ~simp_ctxt lc = in match shortcut simp_ctxt lc with | `True -> rtrue () - | `No_shortcut lc -> - let { expr; qs; extra } = translate_goal s1 assumptions lc in - let model_from sol = - let defs = SMT.get_model sol in - let mo = model_evaluator s1 defs in - model_state := Model (mo, qs) - in - let nlc = SMT.bool_not expr in - let inc = s1.smt_solver in - debug_ack_command s1 (SMT.push 1); - debug_ack_command s1 (SMT.assume (SMT.bool_ands (nlc :: extra))); - let res = SMT.check inc in - (match res with - | SMT.Unsat -> - debug_ack_command s1 (SMT.pop 1); - rtrue () - | SMT.Sat -> - model_from inc; - debug_ack_command s1 (SMT.pop 1); - `False - | SMT.Unknown -> - debug_ack_command s1 (SMT.pop 1); - failwith "Unknown") - + | `No_shortcut lc -> ( + let { expr; qs; extra } = translate_goal s1 assumptions lc in + let model_from sol = + let defs = SMT.get_model sol in + let mo = model_evaluator s1 defs in + model_state := Model (mo, qs) + in + let nlc = SMT.bool_not expr in + let inc = s1.smt_solver in + debug_ack_command s1 (SMT.push 1); + debug_ack_command s1 (SMT.assume (SMT.bool_ands (nlc :: extra))); + let res = SMT.check inc in + match res with + | SMT.Unsat -> + debug_ack_command s1 (SMT.pop 1); + rtrue () + | SMT.Sat -> + model_from inc; + debug_ack_command s1 (SMT.pop 1); + `False + | SMT.Unknown -> + debug_ack_command s1 (SMT.pop 1); + failwith "Unknown") (* let () = Z3.Solver.reset solver.non_incremental in let () = List.iter (fun lc -> Z3.Solver.add solver.non_incremental [lc] ) (nlc :: extra @ existing_scs) in let From 8a46609febc22611d66012180eec5edb08f72643 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 23 Dec 2024 00:23:04 -0500 Subject: [PATCH 119/148] [CN] Fix formatting break from #782 --- backend/cn/lib/solver.ml | 1445 ++++++++++++++++++++------------------ 1 file changed, 766 insertions(+), 679 deletions(-) diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index a6803c607..26ba9a622 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -5,12 +5,12 @@ module LC = LogicalConstraints open LogicalConstraints module Int_BT_Table = Map.Make (struct - type t = int * BT.t + type t = int * BT.t - let compare (int1, bt1) (int2, bt2) = - let cmp = Int.compare int1 int2 in - if cmp != 0 then cmp else BT.compare bt1 bt2 -end) + let compare (int1, bt1) (int2, bt2) = + let cmp = Int.compare int1 int2 in + if cmp != 0 then cmp else BT.compare bt1 bt2 + end) module IntWithHash = struct (* For compatability with older ocamls *) @@ -27,67 +27,79 @@ open Pp (** Functions that pick names for things. *) module CN_Names = struct let var_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) + let named_expr_name = "_cn_named" + let uninterpreted_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) + let struct_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) + let struct_con_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) + let struct_field_name x = Id.pp_string x ^ "_struct_fld" + let datatype_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) + let datatype_con_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) + let datatype_field_name x = Id.pp_string x ^ "_data_fld" end (** Names for constants that may be uninterpreted. See [bt_uninterpreted] *) module CN_Constant = struct let default = ("default_uf", 0) + let mul = ("mul_uf", 1) + let div = ("div_uf", 2) + let exp = ("exp_uf", 3) + let rem = ("rem_uf", 4) + let mod' = ("mod_uf", 5) + let nth_list = ("nth_list_uf", 6) + let array_to_list = ("array_to_list_uf", 7) end -type solver_frame = { - mutable commands : SMT.sexp list; - (** Ack-style SMT commands, most recent first. *) - mutable uninterpreted : SMT.sexp Sym.Map.t; - (** Uninterpreted functions and variables that we've declared. *) - mutable bt_uninterpreted : SMT.sexp Int_BT_Table.t; - (** Uninterpreted constants, indexed by base type. *) - mutable ctypes : int CTypeMap.t; - (** Declarations for C types. Each C type is assigned a unique integer. *) -} +type solver_frame = + { mutable commands : SMT.sexp list; (** Ack-style SMT commands, most recent first. *) + mutable uninterpreted : SMT.sexp Sym.Map.t; + (** Uninterpreted functions and variables that we've declared. *) + mutable bt_uninterpreted : SMT.sexp Int_BT_Table.t; + (** Uninterpreted constants, indexed by base type. *) + mutable ctypes : int CTypeMap.t + (** Declarations for C types. Each C type is assigned a unique integer. *) + } let empty_solver_frame () = - { - commands = []; + { commands = []; uninterpreted = Sym.Map.empty; bt_uninterpreted = Int_BT_Table.empty; - ctypes = CTypeMap.empty; + ctypes = CTypeMap.empty } + let copy_solver_frame f = { f with commands = f.commands } -type solver = { - smt_solver : SMT.solver; (** The SMT solver connection. *) - cur_frame : solver_frame ref; - prev_frames : solver_frame list ref; - (** Push/pop model. Current frame, and previous frames. *) - name_seed : int ref; (** Used to generate names. *) - (* ISD: This could, perhaps, go in the frame. Then when we pop frames, we'd go back to - the old numbers, which should be OK, I think? *) - globals : Global.t; -} +type solver = + { smt_solver : SMT.solver; (** The SMT solver connection. *) + cur_frame : solver_frame ref; + prev_frames : solver_frame list ref; + (** Push/pop model. Current frame, and previous frames. *) + name_seed : int ref; (** Used to generate names. *) + (* ISD: This could, perhaps, go in the frame. Then when we pop frames, we'd go back to + the old numbers, which should be OK, I think? *) + globals : Global.t + } module Debug = struct let dump_frame (f : solver_frame) = let to_string = Sexplib.Sexp.to_string_hum in let append str doc = doc ^/^ !^str in - let dump_sym k v rest = - rest ^/^ bar ^^^ Sym.pp k ^^^ !^"|->" ^^^ !^(to_string v) - in + let dump_sym k v rest = rest ^/^ bar ^^^ Sym.pp k ^^^ !^"|->" ^^^ !^(to_string v) in let dump_bts (_, k) v rest = rest ^/^ bar ^^^ BT.pp k ^^^ !^"|->" ^^^ !^(to_string v) in @@ -97,10 +109,10 @@ module Debug = struct |> Int_BT_Table.fold dump_bts f.bt_uninterpreted |> append "+---------------------------------" + let dump_solver solver = !^"\n|~~~~~~ Start Solver Dump ~~~~~~~|" - ^/^ separate_map hardline dump_frame - (!(solver.cur_frame) :: !(solver.prev_frames)) + ^/^ separate_map hardline dump_frame (!(solver.cur_frame) :: !(solver.prev_frames)) ^/^ !^"|~~~~~~ End Solver Dump ~~~~~~~~~|" end @@ -112,17 +124,18 @@ let search_frames s f = List.find_map f (!(s.cur_frame) :: !(s.prev_frames)) let find_c_type s ty = let rec search count frames = match frames with - | f :: more -> ( - match CTypeMap.find_opt ty f.ctypes with - | Some n -> n - | None -> search (CTypeMap.cardinal f.ctypes + count) more) + | f :: more -> + (match CTypeMap.find_opt ty f.ctypes with + | Some n -> n + | None -> search (CTypeMap.cardinal f.ctypes + count) more) | [] -> - let f = !(s.cur_frame) in - f.ctypes <- CTypeMap.add ty count f.ctypes; - count + let f = !(s.cur_frame) in + f.ctypes <- CTypeMap.add ty count f.ctypes; + count in search 0 (!(s.cur_frame) :: !(s.prev_frames)) + (** Compute a table mapping ints to C types. We use this to map SMT results back to terms. *) let get_ctype_table s = @@ -132,35 +145,41 @@ let get_ctype_table s = List.iter do_frame (!(s.cur_frame) :: !(s.prev_frames)); table + let debug_ack_command s cmd = - try SMT.ack_command s.smt_solver cmd - with SMT.UnexpectedSolverResponse r -> + try SMT.ack_command s.smt_solver cmd with + | SMT.UnexpectedSolverResponse r -> debug 10 (lazy (!^"failed to ack:" ^/^ !^(Sexplib.Sexp.to_string_hum cmd))); debug 10 (lazy (Debug.dump_solver s)); raise (SMT.UnexpectedSolverResponse r) + (** Start a new scope. *) let push s = debug_ack_command s (SMT.push 1); s.prev_frames := !(s.cur_frame) :: !(s.prev_frames); s.cur_frame := empty_solver_frame () + (** Return to the previous scope. Assumes that there is a previous scope. *) let pop s n = - if n = 0 then () + if n = 0 then + () else ( debug_ack_command s (SMT.pop n); let rec drop count xs = match xs with | new_cur :: new_rest -> - if count = 1 then ( - s.cur_frame := new_cur; - s.prev_frames := new_rest) - else drop (count - 1) new_rest + if count = 1 then ( + s.cur_frame := new_cur; + s.prev_frames := new_rest) + else + drop (count - 1) new_rest | _ -> assert false in drop n !(s.prev_frames)) + let num_scopes s = List.length !(s.prev_frames) (** Do an ack_style command. These are logged. *) @@ -169,6 +188,7 @@ let ack_command s cmd = let f = !(s.cur_frame) in f.commands <- cmd :: f.commands + (** Generate a fersh name *) let fresh_name s x = let n = !(s.name_seed) in @@ -176,18 +196,20 @@ let fresh_name s x = let res = x ^ "_" ^ string_of_int n in res + (** Declare an uninterpreted function. *) let declare_uninterpreted s name args_ts res_t = let check f = Sym.Map.find_opt name f.uninterpreted in match search_frames s check with | Some e -> e | None -> - let sname = CN_Names.uninterpreted_name name in - ack_command s (SMT.declare_fun sname args_ts res_t); - let e = SMT.atom sname in - let f = !(s.cur_frame) in - f.uninterpreted <- Sym.Map.add name e f.uninterpreted; - e + let sname = CN_Names.uninterpreted_name name in + ack_command s (SMT.declare_fun sname args_ts res_t); + let e = SMT.atom sname in + let f = !(s.cur_frame) in + f.uninterpreted <- Sym.Map.add name e f.uninterpreted; + e + (** Declare an uninterpreted function, indexed by a base type. *) let declare_bt_uninterpreted s (name, k) bt args_ts res_t = @@ -195,12 +217,13 @@ let declare_bt_uninterpreted s (name, k) bt args_ts res_t = match search_frames s check with | Some e -> e | None -> - let sname = fresh_name s name in - ack_command s (SMT.declare_fun sname args_ts res_t); - let e = SMT.atom sname in - let top_map = !(s.cur_frame).bt_uninterpreted in - !(s.cur_frame).bt_uninterpreted <- Int_BT_Table.add (k, bt) e top_map; - e + let sname = fresh_name s name in + ack_command s (SMT.declare_fun sname args_ts res_t); + let e = SMT.atom sname in + let top_map = !(s.cur_frame).bt_uninterpreted in + !(s.cur_frame).bt_uninterpreted <- Int_BT_Table.add (k, bt) e top_map; + e + (* Note: CVC5 has support for arbitrary tuples without declaring them. Also, instead of declaring a fixed number of tuples ahead of time, we could declare the types on demand @@ -212,11 +235,13 @@ module CN_Tuple = struct let selector arity field = "cn_get_" ^ string_of_int field ^ "_of_" ^ string_of_int arity + (** A tuple type with the given name *) let t tys = let arity = List.length tys in SMT.app_ (name arity) tys + (** Declare a datatype for a struct *) let declare s arity = let name = name arity in @@ -226,11 +251,13 @@ module CN_Tuple = struct let fields = List.init arity field in ack_command s (SMT.declare_datatype name params [ (name, fields) ]) + (** Make a tuple value *) let con es = let arity = List.length es in SMT.app_ (name arity) es + (** Get a field of a tuple *) let get arity field tup = SMT.app_ (selector arity field) [ tup ] end @@ -248,8 +275,11 @@ end module CN_MemByte = struct let name = "mem_byte" + let alloc_id_name = "alloc_id" + let value_name = "value" + let alloc_id_value_name = "AiV" (** Bit-width of memory bytes *) @@ -262,28 +292,31 @@ module CN_MemByte = struct let con ~alloc_id ~value = SMT.app_ alloc_id_value_name [ alloc_id; value ] let declare s = - ack_command s - (SMT.declare_datatype name [] - [ - ( alloc_id_value_name, - [ - (alloc_id_name, CN_AllocId.t ()); (value_name, SMT.t_bits width); - ] ); + ack_command + s + (SMT.declare_datatype + name + [] + [ ( alloc_id_value_name, + [ (alloc_id_name, CN_AllocId.t ()); (value_name, SMT.t_bits width) ] ) ]) end module CN_Pointer = struct let name = "pointer" + let null_name = "NULL" + let alloc_id_addr_name = "AiA" + let alloc_id_name = "alloc_id" + let addr_name = "addr" (** Bit-width of pointers *) let width = - match Memory.uintptr_bt with - | Bits (_, w) -> w - | _ -> failwith "Pointer is not bits" + match Memory.uintptr_bt with Bits (_, w) -> w | _ -> failwith "Pointer is not bits" + (** The name of the pointer type *) let t = SMT.atom name @@ -292,18 +325,24 @@ module CN_Pointer = struct i.e. adding a [functpr] constructor. *) let match_ptr scrutinee ~null_case ~alloc_id_addr_case = SMT.( - match_datatype scrutinee - [ - (PCon (null_name, []), null_case); + match_datatype + scrutinee + [ (PCon (null_name, []), null_case); ( PCon (alloc_id_addr_name, [ alloc_id_name; addr_name ]), - alloc_id_addr_case ~alloc_id:(SMT.atom alloc_id_name) - ~addr:(SMT.atom addr_name) ); + alloc_id_addr_case + ~alloc_id:(SMT.atom alloc_id_name) + ~addr:(SMT.atom addr_name) ) ]) + let ptr_shift_name = "ptr_shift" + let copy_alloc_id_name = "copy_alloc_id" + let alloc_id_of_name = "alloc_id_of" + let bits_to_ptr_name = "bits_to_ptr" + let addr_of_name = "addr_of" (** Make a null pointer value *) @@ -313,80 +352,115 @@ module CN_Pointer = struct let con_aia ~alloc_id ~addr = SMT.app_ alloc_id_addr_name [ alloc_id; addr ] let declare s = - ack_command s - (SMT.declare_datatype name [] - [ - (null_name, []); + ack_command + s + (SMT.declare_datatype + name + [] + [ (null_name, []); ( alloc_id_addr_name, - [ (alloc_id_name, CN_AllocId.t ()); (addr_name, SMT.t_bits width) ] - ); + [ (alloc_id_name, CN_AllocId.t ()); (addr_name, SMT.t_bits width) ] ) ]); - ack_command s - (SMT.define_fun ptr_shift_name + ack_command + s + (SMT.define_fun + ptr_shift_name [ ("p", t); ("offset", SMT.t_bits width); ("null_case", t) ] t - (match_ptr (SMT.atom "p") ~null_case:(SMT.atom "null_case") + (match_ptr + (SMT.atom "p") + ~null_case:(SMT.atom "null_case") ~alloc_id_addr_case:(fun ~alloc_id ~addr -> con_aia ~alloc_id ~addr:(SMT.bv_add addr (SMT.atom "offset"))))); - ack_command s - (SMT.define_fun copy_alloc_id_name + ack_command + s + (SMT.define_fun + copy_alloc_id_name [ ("p", t); ("new_addr", SMT.t_bits width); ("null_case", t) ] t - (match_ptr (SMT.atom "p") ~null_case:(SMT.atom "null_case") + (match_ptr + (SMT.atom "p") + ~null_case:(SMT.atom "null_case") ~alloc_id_addr_case:(fun ~alloc_id ~addr:_ -> con_aia ~alloc_id ~addr:(SMT.atom "new_addr")))); - ack_command s - (SMT.define_fun alloc_id_of_name + ack_command + s + (SMT.define_fun + alloc_id_of_name [ ("p", t); ("null_case", CN_AllocId.t ()) ] (CN_AllocId.t ()) - (match_ptr (SMT.atom "p") ~null_case:(SMT.atom "null_case") + (match_ptr + (SMT.atom "p") + ~null_case:(SMT.atom "null_case") ~alloc_id_addr_case:(fun ~alloc_id ~addr:_ -> alloc_id))); - ack_command s - (SMT.define_fun bits_to_ptr_name + ack_command + s + (SMT.define_fun + bits_to_ptr_name [ ("bits", SMT.t_bits width); ("alloc_id", CN_AllocId.t ()) ] t (SMT.ite (SMT.eq (SMT.atom "bits") (SMT.bv_k width Z.zero)) con_null (con_aia ~addr:(SMT.atom "bits") ~alloc_id:(SMT.atom "alloc_id")))); - ack_command s - (SMT.define_fun addr_of_name + ack_command + s + (SMT.define_fun + addr_of_name [ ("p", t) ] (SMT.t_bits width) - (match_ptr (SMT.atom "p") ~null_case:(SMT.bv_k width Z.zero) + (match_ptr + (SMT.atom "p") + ~null_case:(SMT.bv_k width Z.zero) ~alloc_id_addr_case:(fun ~alloc_id:_ ~addr -> addr))) + let ptr_shift ~ptr ~offset ~null_case = SMT.app_ ptr_shift_name [ ptr; offset; null_case ] + let copy_alloc_id ~ptr ~addr ~null_case = SMT.app_ copy_alloc_id_name [ ptr; addr; null_case ] + let alloc_id_of ~ptr ~null_case = SMT.app_ alloc_id_of_name [ ptr; null_case ] + let bits_to_ptr ~bits ~alloc_id = SMT.app_ bits_to_ptr_name [ bits; alloc_id ] + let addr_of ~ptr = SMT.app_ addr_of_name [ ptr ] end module CN_List = struct let name = "cn_list" + let nil_name = "cn_nil" + let cons_name = "cn_cons" + let head_name = "cn_head" + let tail_name = "cn_tail" + let t a = SMT.app_ name [ a ] let declare s = let a = SMT.atom "a" in - ack_command s - (SMT.declare_datatype name [ "a" ] + ack_command + s + (SMT.declare_datatype + name + [ "a" ] [ (nil_name, []); (cons_name, [ (head_name, a); (tail_name, t a) ]) ]) + let nil elT = SMT.as_type (SMT.atom nil_name) (t elT) + let cons x xs = SMT.app_ cons_name [ x; xs ] let head xs orelse = SMT.ite (SMT.is_con cons_name xs) (SMT.app_ head_name [ xs ]) orelse + let tail xs orelse = SMT.ite (SMT.is_con cons_name xs) (SMT.app_ tail_name [ xs ]) orelse end @@ -411,8 +485,9 @@ let rec translate_base_type = function | Struct tag -> SMT.atom (CN_Names.struct_name tag) | Datatype tag -> SMT.atom (CN_Names.datatype_name tag) | Record members -> - let get_val (_, v) = v in - translate_base_type (Tuple (List.map get_val members)) + let get_val (_, v) = v in + translate_base_type (Tuple (List.map get_val members)) + (** {1 SMT to Term} *) @@ -420,91 +495,91 @@ let rec translate_base_type = function let rec get_ivalue gs ctys bt sexp = IT (get_value gs ctys bt sexp, bt, Cerb_location.unknown) + and get_value gs ctys bt (sexp : SMT.sexp) = match bt with | Unit -> Const Unit | Bool -> Const (Bool (SMT.to_bool sexp)) | Integer -> Const (Z (SMT.to_z sexp)) | Bits (sign, n) -> - let signed = equal_sign sign Signed in - Const (Bits ((sign, n), SMT.to_bits n signed sexp)) + let signed = equal_sign sign Signed in + Const (Bits ((sign, n), SMT.to_bits n signed sexp)) | Real -> Const (Q (SMT.to_q sexp)) - | MemByte -> ( - match SMT.to_con sexp with - | con, [ salloc_id; svalue ] - when String.equal con CN_MemByte.alloc_id_value_name -> - let alloc_id = CN_AllocId.from_sexp salloc_id in - let value = - match - get_value gs ctys (BT.Bits (Unsigned, CN_MemByte.width)) svalue - with - | Const (Bits (_, z)) -> z - | _ -> failwith "Memory byte value is not bits" - in - Const (MemByte { alloc_id; value }) - | _ -> failwith "MemByte") - | Loc () -> ( - match SMT.to_con sexp with - | con, [] when String.equal con CN_Pointer.null_name -> Const Null - | con, [ sbase; saddr ] - when String.equal con CN_Pointer.alloc_id_addr_name -> - let base = CN_AllocId.from_sexp sbase in - let addr = - match get_value gs ctys Memory.uintptr_bt saddr with - | Const (Bits (_, z)) -> z - | _ -> failwith "Pointer value is not bits" - in - Const (Pointer { alloc_id = base; addr }) - | _ -> failwith "Loc") + | MemByte -> + (match SMT.to_con sexp with + | con, [ salloc_id; svalue ] when String.equal con CN_MemByte.alloc_id_value_name -> + let alloc_id = CN_AllocId.from_sexp salloc_id in + let value = + match get_value gs ctys (BT.Bits (Unsigned, CN_MemByte.width)) svalue with + | Const (Bits (_, z)) -> z + | _ -> failwith "Memory byte value is not bits" + in + Const (MemByte { alloc_id; value }) + | _ -> failwith "MemByte") + | Loc () -> + (match SMT.to_con sexp with + | con, [] when String.equal con CN_Pointer.null_name -> Const Null + | con, [ sbase; saddr ] when String.equal con CN_Pointer.alloc_id_addr_name -> + let base = CN_AllocId.from_sexp sbase in + let addr = + match get_value gs ctys Memory.uintptr_bt saddr with + | Const (Bits (_, z)) -> z + | _ -> failwith "Pointer value is not bits" + in + Const (Pointer { alloc_id = base; addr }) + | _ -> failwith "Loc") | Alloc_id -> Const (Alloc_id (CN_AllocId.from_sexp sexp)) - | CType -> ( - try Const (CType_const (Int_Table.find ctys (Z.to_int (SMT.to_z sexp)))) - with Not_found -> Const (Default bt)) - | List elT -> ( - match SMT.to_con sexp with - | con, [] when String.equal con CN_List.nil_name -> Nil elT - | con, [ h; t ] when String.equal con CN_List.cons_name -> - Cons (get_ivalue gs ctys elT h, get_ivalue gs ctys bt t) - | _ -> failwith "List") + | CType -> + (try Const (CType_const (Int_Table.find ctys (Z.to_int (SMT.to_z sexp)))) with + | Not_found -> Const (Default bt)) + | List elT -> + (match SMT.to_con sexp with + | con, [] when String.equal con CN_List.nil_name -> Nil elT + | con, [ h; t ] when String.equal con CN_List.cons_name -> + Cons (get_ivalue gs ctys elT h, get_ivalue gs ctys bt t) + | _ -> failwith "List") | Set _bt -> Const (Default bt) (* FIXME *) | Map (kt, vt) -> - let els, dflt = SMT.to_array sexp in - let base = MapConst (kt, get_ivalue gs ctys vt dflt) in - let add_el (k, v) a = - MapSet - ( IT (a, bt, Cerb_location.unknown), - get_ivalue gs ctys kt k, - get_ivalue gs ctys vt v ) - in - List.fold_right add_el els base + let els, dflt = SMT.to_array sexp in + let base = MapConst (kt, get_ivalue gs ctys vt dflt) in + let add_el (k, v) a = + MapSet + ( IT (a, bt, Cerb_location.unknown), + get_ivalue gs ctys kt k, + get_ivalue gs ctys vt v ) + in + List.fold_right add_el els base | Tuple bts -> - let _con, vals = SMT.to_con sexp in - Tuple (List.map2 (get_ivalue gs ctys) bts vals) + let _con, vals = SMT.to_con sexp in + Tuple (List.map2 (get_ivalue gs ctys) bts vals) | Struct tag -> - let _con, vals = SMT.to_con sexp in - let decl = Sym.Map.find tag gs.struct_decls in - let fields = List.filter_map (fun x -> x.Memory.member_or_padding) decl in - let mk_field (l, t) v = (l, get_ivalue gs ctys (Memory.bt_of_sct t) v) in - Struct (tag, List.map2 mk_field fields vals) - | Datatype tag -> ( - let con, vals = SMT.to_con sexp in - let cons = (Sym.Map.find tag gs.datatypes).constrs in - let do_con c = - let fields = (Sym.Map.find c gs.datatype_constrs).params in - let mk_field (l, t) v = (l, get_ivalue gs ctys t v) in - Constructor (c, List.map2 mk_field fields vals) - in - let try_con c = - if String.equal con (CN_Names.datatype_con_name c) then Some (do_con c) - else None - in - match List.find_map try_con cons with - | Some yes -> yes - | None -> failwith "Missing constructor") + let _con, vals = SMT.to_con sexp in + let decl = Sym.Map.find tag gs.struct_decls in + let fields = List.filter_map (fun x -> x.Memory.member_or_padding) decl in + let mk_field (l, t) v = (l, get_ivalue gs ctys (Memory.bt_of_sct t) v) in + Struct (tag, List.map2 mk_field fields vals) + | Datatype tag -> + let con, vals = SMT.to_con sexp in + let cons = (Sym.Map.find tag gs.datatypes).constrs in + let do_con c = + let fields = (Sym.Map.find c gs.datatype_constrs).params in + let mk_field (l, t) v = (l, get_ivalue gs ctys t v) in + Constructor (c, List.map2 mk_field fields vals) + in + let try_con c = + if String.equal con (CN_Names.datatype_con_name c) then + Some (do_con c) + else + None + in + (match List.find_map try_con cons with + | Some yes -> yes + | None -> failwith "Missing constructor") | Record members -> - let _con, vals = SMT.to_con sexp in - let mk_field (l, bt) e = (l, get_ivalue gs ctys bt e) in - Record (List.map2 mk_field members vals) + let _con, vals = SMT.to_con sexp in + let mk_field (l, bt) e = (l, get_ivalue gs ctys bt e) in + Record (List.map2 mk_field members vals) + (** {1 Term to SMT} *) @@ -515,21 +590,21 @@ let translate_const s co = | Bits ((_, w), z) -> SMT.bv_k w z | Q q -> SMT.real_k q | MemByte b -> - CN_MemByte.con - ~alloc_id:(CN_AllocId.to_sexp b.alloc_id) - ~value:(SMT.bv_k CN_MemByte.width b.value) + CN_MemByte.con + ~alloc_id:(CN_AllocId.to_sexp b.alloc_id) + ~value:(SMT.bv_k CN_MemByte.width b.value) | Pointer p -> - CN_Pointer.con_aia - ~alloc_id:(CN_AllocId.to_sexp p.alloc_id) - ~addr:(SMT.bv_k CN_Pointer.width p.addr) + CN_Pointer.con_aia + ~alloc_id:(CN_AllocId.to_sexp p.alloc_id) + ~addr:(SMT.bv_k CN_Pointer.width p.addr) | Alloc_id z -> CN_AllocId.to_sexp z | Bool b -> SMT.bool_k b | Unit -> SMT.atom (CN_Tuple.name 0) | Null -> CN_Pointer.con_null | CType_const ct -> SMT.int_k (find_c_type s ct) | Default t -> - declare_bt_uninterpreted s CN_Constant.default t [] - (translate_base_type t) + declare_bt_uninterpreted s CN_Constant.default t [] (translate_base_type t) + (** Casting between bit-vector types *) let bv_cast ~to_ ~from x = @@ -546,6 +621,7 @@ let bv_cast ~to_ ~from x = | _ when from_signed -> SMT.bv_sign_extend (to_sz - from_sz) x | _ -> SMT.bv_zero_extend (to_sz - from_sz) x + (** [bv_clz rw w e] counts the leading zeroes in [e], which should be a bit-vector of width [w]. The result is a bit-vector of width [rw]. Note that this duplicates [e]. *) @@ -553,18 +629,21 @@ let bv_clz result_w = let result k = SMT.bv_k result_w k in let eq_0 w e = SMT.eq e (SMT.bv_k w Z.zero) in let rec count w e = - if w = 1 then SMT.ite (eq_0 w e) (result Z.one) (result Z.zero) - else + if w = 1 then + SMT.ite (eq_0 w e) (result Z.one) (result Z.zero) + else ( let top_w = w / 2 in let bot_w = w - top_w in let top = SMT.bv_extract (w - 1) (w - top_w) e in let bot = SMT.bv_extract (bot_w - 1) 0 e in - SMT.ite (eq_0 top_w top) + SMT.ite + (eq_0 top_w top) (SMT.bv_add (count bot_w bot) (result (Z.of_int top_w))) - (count top_w top) + (count top_w top)) in count + (** [bv_ctz rw w e] counts the tailing zeroes in [e], which should be a bit-vector of width [w]. The result is a bit-vector of width [rw]. Note that this duplicates [e]. *) @@ -572,40 +651,45 @@ let bv_ctz result_w = let result k = SMT.bv_k result_w k in let eq_0 w e = SMT.eq e (SMT.bv_k w Z.zero) in let rec count w e = - if w = 1 then SMT.ite (eq_0 w e) (result Z.one) (result Z.zero) - else + if w = 1 then + SMT.ite (eq_0 w e) (result Z.one) (result Z.zero) + else ( let top_w = w / 2 in let bot_w = w - top_w in let top = SMT.bv_extract (w - 1) (w - top_w) e in let bot = SMT.bv_extract (bot_w - 1) 0 e in - SMT.ite (eq_0 bot_w bot) + SMT.ite + (eq_0 bot_w bot) (SMT.bv_add (count top_w top) (result (Z.of_int bot_w))) - (count bot_w bot) + (count bot_w bot)) in count + (** Translate a variable to SMT. Declare if needed. *) let translate_var s name bt = let check f = Sym.Map.find_opt name f.uninterpreted in match search_frames s check with | Some e -> e | None -> - let sname = CN_Names.var_name name in - ack_command s (SMT.declare sname (translate_base_type bt)); - let e = SMT.atom sname in - let f = !(s.cur_frame) in - f.uninterpreted <- Sym.Map.add name e f.uninterpreted; - e + let sname = CN_Names.var_name name in + ack_command s (SMT.declare sname (translate_base_type bt)); + let e = SMT.atom sname in + let f = !(s.cur_frame) in + f.uninterpreted <- Sym.Map.add name e f.uninterpreted; + e + (** Translate a CN term to SMT *) let rec translate_term s iterm = let loc = IT.loc iterm in let struct_decls = s.globals.struct_decls in let maybe_name e k = - if SMT.is_atom e then k e - else + if SMT.is_atom e then + k e + else ( let x = fresh_name s CN_Names.named_expr_name in - SMT.let_ [ (x, e) ] (k (SMT.atom x)) + SMT.let_ [ (x, e) ] (k (SMT.atom x))) in let default bt = let here = Locations.other (__FUNCTION__ ^ string_of_int __LINE__) in @@ -614,386 +698,391 @@ let rec translate_term s iterm = match IT.term iterm with | Const c -> translate_const s c | Sym x -> translate_var s x (IT.basetype iterm) - | Unop (op, e1) -> ( - match op with - | BW_FFS_NoSMT -> - (* NOTE: This desugaring duplicates e1 *) - let intl i = int_lit_ i (IT.bt e1) loc in - translate_term s - (ite_ - ( eq_ (e1, intl 0) loc, - intl 0, - add_ (arith_unop BW_CTZ_NoSMT e1 loc, intl 1) loc ) - loc) - | BW_FLS_NoSMT -> - (* copying and adjusting BW_FFS_NoSMT rule *) - (* NOTE: This desugaring duplicates e1 *) - let sz = - match IT.bt e1 with Bits (_sign, n) -> n | _ -> assert false - in - let intl i = int_lit_ i (IT.bt e1) loc in - translate_term s - (ite_ - ( eq_ (e1, intl 0) loc, - intl 0, - sub_ (intl sz, arith_unop BW_CLZ_NoSMT e1 loc) loc ) - loc) - | Not -> SMT.bool_not (translate_term s e1) - | Negate -> ( - match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_neg (translate_term s e1) - | BT.Integer | BT.Real -> SMT.num_neg (translate_term s e1) - | _ -> failwith (__FUNCTION__ ^ ":Unop (Negate, _)")) - | BW_Compl -> ( - match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_compl (translate_term s e1) - | _ -> failwith (__FUNCTION__ ^ ":Unop (BW_Compl, _)")) - | BW_CLZ_NoSMT -> ( - match IT.basetype iterm with - | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_clz w w) - | _ -> failwith "solver: BW_CLZ_NoSMT: not a bitwise type") - | BW_CTZ_NoSMT -> ( - match IT.basetype iterm with - | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_ctz w w) - | _ -> failwith "solver: BW_CTZ_NoSMT: not a bitwise type")) - | Binop (op, e1, e2) -> ( - let s1 = translate_term s e1 in - let s2 = translate_term s e2 in - (* binary uninterpreted function, same type for arguments and result. *) - let uninterp_same_type k = - let bt = IT.basetype iterm in - let smt_t = translate_base_type bt in - let f = declare_bt_uninterpreted s k bt [ smt_t; smt_t ] smt_t in - SMT.app f [ s1; s2 ] - in - match op with - | And -> SMT.bool_and s1 s2 - | Or -> SMT.bool_or s1 s2 - | Implies -> SMT.bool_implies s1 s2 - | Add -> ( - match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_add s1 s2 - | BT.Integer | BT.Real -> SMT.num_add s1 s2 - | _ -> failwith "Add") - | Sub -> ( - match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_sub s1 s2 - | BT.Integer | BT.Real -> SMT.num_sub s1 s2 - | _ -> failwith "Sub") - | Mul -> ( - match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_mul s1 s2 - | BT.Integer | BT.Real -> SMT.num_mul s1 s2 - | _ -> failwith "Mul") - | MulNoSMT -> uninterp_same_type CN_Constant.mul - | Div -> ( - match IT.basetype iterm with - | BT.Bits (BT.Signed, _) -> SMT.bv_sdiv s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_udiv s1 s2 - | BT.Integer | BT.Real -> SMT.num_div s1 s2 - | _ -> failwith "Div") - | DivNoSMT -> uninterp_same_type CN_Constant.div - | Exp -> ( - match (get_num_z e1, get_num_z e2) with - | Some z1, Some z2 when Z.fits_int z2 -> - translate_term s - (num_lit_ (Z.pow z1 (Z.to_int z2)) (IT.bt e1) loc) - | _, _ -> failwith "Exp") - | ExpNoSMT -> uninterp_same_type CN_Constant.exp - | Rem -> ( - match IT.basetype iterm with - | BT.Bits (BT.Signed, _) -> SMT.bv_srem s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 - | BT.Integer -> SMT.num_rem s1 s2 (* CVC5 ?? *) - | _ -> failwith "Rem") - | RemNoSMT -> uninterp_same_type CN_Constant.rem - | Mod -> ( - match IT.basetype iterm with - | BT.Bits (BT.Signed, _) -> SMT.bv_smod s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 - | BT.Integer -> SMT.num_mod s1 s2 - | _ -> failwith "Mod") - | ModNoSMT -> uninterp_same_type CN_Constant.mod' - | BW_Xor -> ( - match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_xor s1 s2 - | _ -> failwith "BW_Xor") - | BW_And -> ( - match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_and s1 s2 - | _ -> failwith "BW_And") - | BW_Or -> ( - match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_or s1 s2 - | _ -> failwith "BW_Or") - (* Shift amount should be positive? *) - | ShiftLeft -> ( - match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_shl s1 s2 - | _ -> failwith "ShiftLeft") - (* Amount should be positive? *) - | ShiftRight -> ( - match IT.basetype iterm with - | BT.Bits (BT.Signed, _) -> SMT.bv_ashr s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_lshr s1 s2 - | _ -> failwith "ShiftRight") - | LT -> ( - match IT.basetype e1 with - | BT.Bits (BT.Signed, _) -> SMT.bv_slt s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_ult s1 s2 - | BT.Integer | BT.Real -> SMT.num_lt s1 s2 - | _ -> failwith "LT") - | LE -> ( - match IT.basetype e1 with - | BT.Bits (BT.Signed, _) -> SMT.bv_sleq s1 s2 - | BT.Bits (BT.Unsigned, _) -> SMT.bv_uleq s1 s2 - | BT.Integer | BT.Real -> SMT.num_leq s1 s2 - | ty -> - Pp.print stdout (!^"LE" ^^^ BT.pp ty); - failwith "LE") - (* NOTE: duplicates terms *) - | Min -> translate_term s (ite_ (le_ (e1, e2) loc, e1, e2) loc) - (* NOTE: duplicates terms *) - | Max -> translate_term s (ite_ (ge_ (e1, e2) loc, e1, e2) loc) - | EQ -> SMT.eq s1 s2 - | LTPointer -> - let uintptr_cast = cast_ Memory.uintptr_bt in - translate_term s (lt_ (uintptr_cast e1 loc, uintptr_cast e2 loc) loc) - | LEPointer -> - let uintptr_cast = cast_ Memory.uintptr_bt in - translate_term s (le_ (uintptr_cast e1 loc, uintptr_cast e2 loc) loc) - | SetUnion -> SMT.set_union s.smt_solver.config.exts s1 s2 - | SetIntersection -> SMT.set_intersection s.smt_solver.config.exts s1 s2 - | SetDifference -> SMT.set_difference s.smt_solver.config.exts s1 s2 - | SetMember -> SMT.set_member s.smt_solver.config.exts s1 s2 - | Subset -> SMT.set_subset s.smt_solver.config.exts s1 s2) + | Unop (op, e1) -> + (match op with + | BW_FFS_NoSMT -> + (* NOTE: This desugaring duplicates e1 *) + let intl i = int_lit_ i (IT.bt e1) loc in + translate_term + s + (ite_ + ( eq_ (e1, intl 0) loc, + intl 0, + add_ (arith_unop BW_CTZ_NoSMT e1 loc, intl 1) loc ) + loc) + | BW_FLS_NoSMT -> + (* copying and adjusting BW_FFS_NoSMT rule *) + (* NOTE: This desugaring duplicates e1 *) + let sz = match IT.bt e1 with Bits (_sign, n) -> n | _ -> assert false in + let intl i = int_lit_ i (IT.bt e1) loc in + translate_term + s + (ite_ + ( eq_ (e1, intl 0) loc, + intl 0, + sub_ (intl sz, arith_unop BW_CLZ_NoSMT e1 loc) loc ) + loc) + | Not -> SMT.bool_not (translate_term s e1) + | Negate -> + (match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_neg (translate_term s e1) + | BT.Integer | BT.Real -> SMT.num_neg (translate_term s e1) + | _ -> failwith (__FUNCTION__ ^ ":Unop (Negate, _)")) + | BW_Compl -> + (match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_compl (translate_term s e1) + | _ -> failwith (__FUNCTION__ ^ ":Unop (BW_Compl, _)")) + | BW_CLZ_NoSMT -> + (match IT.basetype iterm with + | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_clz w w) + | _ -> failwith "solver: BW_CLZ_NoSMT: not a bitwise type") + | BW_CTZ_NoSMT -> + (match IT.basetype iterm with + | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_ctz w w) + | _ -> failwith "solver: BW_CTZ_NoSMT: not a bitwise type")) + | Binop (op, e1, e2) -> + let s1 = translate_term s e1 in + let s2 = translate_term s e2 in + (* binary uninterpreted function, same type for arguments and result. *) + let uninterp_same_type k = + let bt = IT.basetype iterm in + let smt_t = translate_base_type bt in + let f = declare_bt_uninterpreted s k bt [ smt_t; smt_t ] smt_t in + SMT.app f [ s1; s2 ] + in + (match op with + | And -> SMT.bool_and s1 s2 + | Or -> SMT.bool_or s1 s2 + | Implies -> SMT.bool_implies s1 s2 + | Add -> + (match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_add s1 s2 + | BT.Integer | BT.Real -> SMT.num_add s1 s2 + | _ -> failwith "Add") + | Sub -> + (match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_sub s1 s2 + | BT.Integer | BT.Real -> SMT.num_sub s1 s2 + | _ -> failwith "Sub") + | Mul -> + (match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_mul s1 s2 + | BT.Integer | BT.Real -> SMT.num_mul s1 s2 + | _ -> failwith "Mul") + | MulNoSMT -> uninterp_same_type CN_Constant.mul + | Div -> + (match IT.basetype iterm with + | BT.Bits (BT.Signed, _) -> SMT.bv_sdiv s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_udiv s1 s2 + | BT.Integer | BT.Real -> SMT.num_div s1 s2 + | _ -> failwith "Div") + | DivNoSMT -> uninterp_same_type CN_Constant.div + | Exp -> + (match (get_num_z e1, get_num_z e2) with + | Some z1, Some z2 when Z.fits_int z2 -> + translate_term s (num_lit_ (Z.pow z1 (Z.to_int z2)) (IT.bt e1) loc) + | _, _ -> failwith "Exp") + | ExpNoSMT -> uninterp_same_type CN_Constant.exp + | Rem -> + (match IT.basetype iterm with + | BT.Bits (BT.Signed, _) -> SMT.bv_srem s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 + | BT.Integer -> SMT.num_rem s1 s2 (* CVC5 ?? *) + | _ -> failwith "Rem") + | RemNoSMT -> uninterp_same_type CN_Constant.rem + | Mod -> + (match IT.basetype iterm with + | BT.Bits (BT.Signed, _) -> SMT.bv_smod s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 + | BT.Integer -> SMT.num_mod s1 s2 + | _ -> failwith "Mod") + | ModNoSMT -> uninterp_same_type CN_Constant.mod' + | BW_Xor -> + (match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_xor s1 s2 + | _ -> failwith "BW_Xor") + | BW_And -> + (match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_and s1 s2 + | _ -> failwith "BW_And") + | BW_Or -> + (match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_or s1 s2 + | _ -> failwith "BW_Or") + (* Shift amount should be positive? *) + | ShiftLeft -> + (match IT.basetype iterm with + | BT.Bits _ -> SMT.bv_shl s1 s2 + | _ -> failwith "ShiftLeft") + (* Amount should be positive? *) + | ShiftRight -> + (match IT.basetype iterm with + | BT.Bits (BT.Signed, _) -> SMT.bv_ashr s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_lshr s1 s2 + | _ -> failwith "ShiftRight") + | LT -> + (match IT.basetype e1 with + | BT.Bits (BT.Signed, _) -> SMT.bv_slt s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_ult s1 s2 + | BT.Integer | BT.Real -> SMT.num_lt s1 s2 + | _ -> failwith "LT") + | LE -> + (match IT.basetype e1 with + | BT.Bits (BT.Signed, _) -> SMT.bv_sleq s1 s2 + | BT.Bits (BT.Unsigned, _) -> SMT.bv_uleq s1 s2 + | BT.Integer | BT.Real -> SMT.num_leq s1 s2 + | ty -> + Pp.print stdout (!^"LE" ^^^ BT.pp ty); + failwith "LE") + (* NOTE: duplicates terms *) + | Min -> translate_term s (ite_ (le_ (e1, e2) loc, e1, e2) loc) + (* NOTE: duplicates terms *) + | Max -> translate_term s (ite_ (ge_ (e1, e2) loc, e1, e2) loc) + | EQ -> SMT.eq s1 s2 + | LTPointer -> + let uintptr_cast = cast_ Memory.uintptr_bt in + translate_term s (lt_ (uintptr_cast e1 loc, uintptr_cast e2 loc) loc) + | LEPointer -> + let uintptr_cast = cast_ Memory.uintptr_bt in + translate_term s (le_ (uintptr_cast e1 loc, uintptr_cast e2 loc) loc) + | SetUnion -> SMT.set_union s.smt_solver.config.exts s1 s2 + | SetIntersection -> SMT.set_intersection s.smt_solver.config.exts s1 s2 + | SetDifference -> SMT.set_difference s.smt_solver.config.exts s1 s2 + | SetMember -> SMT.set_member s.smt_solver.config.exts s1 s2 + | Subset -> SMT.set_subset s.smt_solver.config.exts s1 s2) | ITE (b, e1, e2) -> - SMT.ite (translate_term s b) (translate_term s e1) (translate_term s e2) + SMT.ite (translate_term s b) (translate_term s e1) (translate_term s e2) | EachI ((i1, (x, bt), i2), t) -> - let rec aux i = - if i <= i2 then - let su = make_subst [ (x, num_lit_ (Z.of_int i) bt loc) ] in - let t1 = IT.subst su t in - if i = i2 then t1 else IT.and2_ (t1, aux (i + 1)) loc - else failwith "EachI" - in - if i1 > i2 then translate_term s (IT.bool_ true loc) - else translate_term s (aux i1) + let rec aux i = + if i <= i2 then ( + let su = make_subst [ (x, num_lit_ (Z.of_int i) bt loc) ] in + let t1 = IT.subst su t in + if i = i2 then t1 else IT.and2_ (t1, aux (i + 1)) loc) + else + failwith "EachI" + in + if i1 > i2 then + translate_term s (IT.bool_ true loc) + else + translate_term s (aux i1) (* Tuples *) | Tuple es -> CN_Tuple.con (List.map (translate_term s) es) - | NthTuple (n, e1) -> ( - match IT.basetype e1 with - | Tuple ts -> CN_Tuple.get (List.length ts) n (translate_term s e1) - | _ -> failwith "NthTuple: not a tuple") + | NthTuple (n, e1) -> + (match IT.basetype e1 with + | Tuple ts -> CN_Tuple.get (List.length ts) n (translate_term s e1) + | _ -> failwith "NthTuple: not a tuple") (* Structs *) (* assumes that the fileds are in the correct order *) | Struct (tag, fields) -> - let con = CN_Names.struct_con_name tag in - let field (_, e) = translate_term s e in - SMT.app_ con (List.map field fields) + let con = CN_Names.struct_con_name tag in + let field (_, e) = translate_term s e in + SMT.app_ con (List.map field fields) | StructMember (e1, f) -> - SMT.app_ (CN_Names.struct_field_name f) [ translate_term s e1 ] + SMT.app_ (CN_Names.struct_field_name f) [ translate_term s e1 ] | StructUpdate ((t, member), v) -> - let tag = BT.struct_bt (IT.bt t) in - let layout = Sym.Map.find (struct_bt (IT.bt t)) struct_decls in - let members = Memory.member_types layout in - let str = - List.map - (fun (member', sct) -> - let value = - if Id.equal member member' then v - else member_ ~member_bt:(Memory.bt_of_sct sct) (t, member') loc - in - (member', value)) - members - in - translate_term s (struct_ (tag, str) loc) + let tag = BT.struct_bt (IT.bt t) in + let layout = Sym.Map.find (struct_bt (IT.bt t)) struct_decls in + let members = Memory.member_types layout in + let str = + List.map + (fun (member', sct) -> + let value = + if Id.equal member member' then + v + else + member_ ~member_bt:(Memory.bt_of_sct sct) (t, member') loc + in + (member', value)) + members + in + translate_term s (struct_ (tag, str) loc) | OffsetOf (tag, member) -> - let decl = Sym.Map.find tag struct_decls in - let v = Option.get (Memory.member_offset decl member) in - translate_term s (int_lit_ v (IT.basetype iterm) loc) + let decl = Sym.Map.find tag struct_decls in + let v = Option.get (Memory.member_offset decl member) in + translate_term s (int_lit_ v (IT.basetype iterm) loc) (* Records *) | Record members -> - let field (_, e) = translate_term s e in - CN_Tuple.con (List.map field members) - | RecordMember (e1, f) -> ( - match IT.basetype e1 with - | Record members -> ( - let check (x, _) = Id.equal f x in - let arity = List.length members in - match List.find_index check members with - | Some n -> CN_Tuple.get arity n (translate_term s e1) - | None -> failwith "Missing record field.") - | _ -> failwith "RecordMemmber") + let field (_, e) = translate_term s e in + CN_Tuple.con (List.map field members) + | RecordMember (e1, f) -> + (match IT.basetype e1 with + | Record members -> + let check (x, _) = Id.equal f x in + let arity = List.length members in + (match List.find_index check members with + | Some n -> CN_Tuple.get arity n (translate_term s e1) + | None -> failwith "Missing record field.") + | _ -> failwith "RecordMemmber") | RecordUpdate ((t, member), v) -> - let members = BT.record_bt (IT.bt t) in - let str = - List.map - (fun (member', bt) -> - let value = - if Id.equal member member' then v - else IT (RecordMember (t, member'), bt, loc) - in - (member', value)) - members - in - translate_term s (IT (Record str, IT.bt t, loc)) + let members = BT.record_bt (IT.bt t) in + let str = + List.map + (fun (member', bt) -> + let value = + if Id.equal member member' then + v + else + IT (RecordMember (t, member'), bt, loc) + in + (member', value)) + members + in + translate_term s (IT (Record str, IT.bt t, loc)) | MemberShift (t, tag, member) -> - CN_Pointer.ptr_shift ~ptr:(translate_term s t) - ~null_case:(default (Loc ())) - ~offset: - (translate_term s - (IT (OffsetOf (tag, member), Memory.uintptr_bt, loc))) + CN_Pointer.ptr_shift + ~ptr:(translate_term s t) + ~null_case:(default (Loc ())) + ~offset:(translate_term s (IT (OffsetOf (tag, member), Memory.uintptr_bt, loc))) | ArrayShift { base; ct; index } -> - CN_Pointer.ptr_shift ~ptr:(translate_term s base) - ~null_case:(default (Loc ())) - ~offset: - (let el_size = - int_lit_ (Memory.size_of_ctype ct) Memory.uintptr_bt loc - in - (* locations don't matter here - we are translating straight away *) - let ix = - if BT.equal (IT.bt index) Memory.uintptr_bt then index - else cast_ Memory.uintptr_bt index loc - in - translate_term s (mul_ (el_size, ix) loc)) + CN_Pointer.ptr_shift + ~ptr:(translate_term s base) + ~null_case:(default (Loc ())) + ~offset: + (let el_size = int_lit_ (Memory.size_of_ctype ct) Memory.uintptr_bt loc in + (* locations don't matter here - we are translating straight away *) + let ix = + if BT.equal (IT.bt index) Memory.uintptr_bt then + index + else + cast_ Memory.uintptr_bt index loc + in + translate_term s (mul_ (el_size, ix) loc)) | CopyAllocId { addr; loc } -> - CN_Pointer.copy_alloc_id ~ptr:(translate_term s loc) - ~null_case:(default (Loc ())) ~addr:(translate_term s addr) - | HasAllocId loc -> - SMT.is_con CN_Pointer.alloc_id_addr_name (translate_term s loc) + CN_Pointer.copy_alloc_id + ~ptr:(translate_term s loc) + ~null_case:(default (Loc ())) + ~addr:(translate_term s addr) + | HasAllocId loc -> SMT.is_con CN_Pointer.alloc_id_addr_name (translate_term s loc) (* Lists *) | Nil bt -> CN_List.nil (translate_base_type bt) | Cons (e1, e2) -> CN_List.cons (translate_term s e1) (translate_term s e2) | Head e1 -> - maybe_name (translate_term s e1) (fun xs -> - CN_List.head xs (translate_term s (default_ (IT.basetype iterm) loc))) + maybe_name (translate_term s e1) (fun xs -> + CN_List.head xs (translate_term s (default_ (IT.basetype iterm) loc))) | Tail e1 -> - maybe_name (translate_term s e1) (fun xs -> - CN_List.tail xs (translate_term s (default_ (IT.basetype iterm) loc))) + maybe_name (translate_term s e1) (fun xs -> + CN_List.tail xs (translate_term s (default_ (IT.basetype iterm) loc))) | NthList (x, y, z) -> - let arg x = (translate_base_type (IT.basetype x), translate_term s x) in - let arg_ts, args = List.split (List.map arg [ x; y; z ]) in - let bt = IT.basetype iterm in - let res_t = translate_base_type bt in - let f = declare_bt_uninterpreted s CN_Constant.nth_list bt arg_ts res_t in - SMT.app f args + let arg x = (translate_base_type (IT.basetype x), translate_term s x) in + let arg_ts, args = List.split (List.map arg [ x; y; z ]) in + let bt = IT.basetype iterm in + let res_t = translate_base_type bt in + let f = declare_bt_uninterpreted s CN_Constant.nth_list bt arg_ts res_t in + SMT.app f args | ArrayToList (x, y, z) -> - let arg x = (translate_base_type (IT.basetype x), translate_term s x) in - let arg_ts, args = List.split (List.map arg [ x; y; z ]) in - let bt = IT.basetype iterm in - let res_t = translate_base_type bt in - let f = - declare_bt_uninterpreted s CN_Constant.array_to_list bt arg_ts res_t - in - SMT.app f args + let arg x = (translate_base_type (IT.basetype x), translate_term s x) in + let arg_ts, args = List.split (List.map arg [ x; y; z ]) in + let bt = IT.basetype iterm in + let res_t = translate_base_type bt in + let f = declare_bt_uninterpreted s CN_Constant.array_to_list bt arg_ts res_t in + SMT.app f args | SizeOf ct -> - translate_term s - (IT.int_lit_ (Memory.size_of_ctype ct) (IT.basetype iterm) loc) - | Representable (ct, t) -> - translate_term s (representable struct_decls ct t loc) + translate_term s (IT.int_lit_ (Memory.size_of_ctype ct) (IT.basetype iterm) loc) + | Representable (ct, t) -> translate_term s (representable struct_decls ct t loc) | Good (ct, t) -> translate_term s (good_value struct_decls ct t loc) | Aligned t -> - let addr = addr_ t.t loc in - assert (BT.equal (IT.bt addr) (IT.bt t.align)); - translate_term s (divisible_ (addr, t.align) loc) + let addr = addr_ t.t loc in + assert (BT.equal (IT.bt addr) (IT.bt t.align)); + translate_term s (divisible_ (addr, t.align) loc) (* Maps *) | MapConst (bt, e1) -> - let kt = translate_base_type bt in - let vt = translate_base_type (IT.basetype e1) in - SMT.arr_const kt vt (translate_term s e1) + let kt = translate_base_type bt in + let vt = translate_base_type (IT.basetype e1) in + SMT.arr_const kt vt (translate_term s e1) | MapSet (mp, k, v) -> - SMT.arr_store (translate_term s mp) (translate_term s k) - (translate_term s v) + SMT.arr_store (translate_term s mp) (translate_term s k) (translate_term s v) | MapGet (mp, k) -> SMT.arr_select (translate_term s mp) (translate_term s k) | MapDef _ -> failwith "MapDef" - | Apply (name, args) -> ( - let def = Option.get (get_logical_function_def s.globals name) in - match def.body with - | Def body -> - translate_term s (Definition.Function.open_ def.args body args) - | _ -> - let do_arg arg = translate_base_type (IT.basetype arg) in - let args_ts = List.map do_arg args in - let res_t = translate_base_type def.return_bt in - let fu = declare_uninterpreted s name args_ts res_t in - SMT.app fu (List.map (translate_term s) args)) + | Apply (name, args) -> + let def = Option.get (get_logical_function_def s.globals name) in + (match def.body with + | Def body -> translate_term s (Definition.Function.open_ def.args body args) + | _ -> + let do_arg arg = translate_base_type (IT.basetype arg) in + let args_ts = List.map do_arg args in + let res_t = translate_base_type def.return_bt in + let fu = declare_uninterpreted s name args_ts res_t in + SMT.app fu (List.map (translate_term s) args)) | Let ((x, e1), e2) -> - let se1 = translate_term s e1 in - let name = CN_Names.var_name x in - let se2 = translate_term s e2 in - SMT.let_ [ (name, se1) ] se2 + let se1 = translate_term s e1 in + let name = CN_Names.var_name x in + let se2 = translate_term s e2 in + SMT.let_ [ (name, se1) ] se2 (* Datatypes *) (* Assumes the fields are in the correct order *) | Constructor (c, fields) -> - let con = CN_Names.datatype_con_name c in - let field (_, e) = translate_term s e in - SMT.app_ con (List.map field fields) - (* CN supports nested patterns, while SMTLIB does not, so we compile patterns to a - optional predicate, and defined variables. *) + let con = CN_Names.datatype_con_name c in + let field (_, e) = translate_term s e in + SMT.app_ con (List.map field fields) + (* CN supports nested patterns, while SMTLIB does not, so we compile patterns to a + optional predicate, and defined variables. *) | Match (e1, alts) -> - let rec match_pat v (Pat (pat, _, _)) = - match pat with - | PSym x -> (None, [ (CN_Names.var_name x, v) ]) - | PWild -> (None, []) - | PConstructor (c, fs) -> - let field (f, nested) = - let new_v = SMT.app_ (CN_Names.datatype_field_name f) [ v ] in - match_pat new_v nested - in - let conds, defs = List.split (List.map field fs) in - let nested_cond = - SMT.bool_ands (List.filter_map (fun x -> x) conds) - in - let cname = CN_Names.datatype_con_name c in - let cond = SMT.bool_and (SMT.is_con cname v) nested_cond in - (Some cond, List.concat defs) - in - let rec do_alts v alts = - match alts with - | [] -> translate_term s (default_ (IT.basetype iterm) loc) - | (pat, rhs) :: more -> ( - let mb_cond, binds = match_pat v pat in - let k = SMT.let_ binds (translate_term s rhs) in - match mb_cond with - | Some cond -> SMT.ite cond k (do_alts v more) - | None -> k) - in - let x = fresh_name s "match" in - SMT.let_ [ (x, translate_term s e1) ] (do_alts (SMT.atom x) alts) + let rec match_pat v (Pat (pat, _, _)) = + match pat with + | PSym x -> (None, [ (CN_Names.var_name x, v) ]) + | PWild -> (None, []) + | PConstructor (c, fs) -> + let field (f, nested) = + let new_v = SMT.app_ (CN_Names.datatype_field_name f) [ v ] in + match_pat new_v nested + in + let conds, defs = List.split (List.map field fs) in + let nested_cond = SMT.bool_ands (List.filter_map (fun x -> x) conds) in + let cname = CN_Names.datatype_con_name c in + let cond = SMT.bool_and (SMT.is_con cname v) nested_cond in + (Some cond, List.concat defs) + in + let rec do_alts v alts = + match alts with + | [] -> translate_term s (default_ (IT.basetype iterm) loc) + | (pat, rhs) :: more -> + let mb_cond, binds = match_pat v pat in + let k = SMT.let_ binds (translate_term s rhs) in + (match mb_cond with Some cond -> SMT.ite cond k (do_alts v more) | None -> k) + in + let x = fresh_name s "match" in + SMT.let_ [ (x, translate_term s e1) ] (do_alts (SMT.atom x) alts) (* Casts *) | WrapI (ity, arg) -> - bv_cast - ~to_:(Memory.bt_of_sct (Sctypes.Integer ity)) - ~from:(IT.bt arg) (translate_term s arg) - | Cast (cbt, t) -> ( - let smt_term = translate_term s t in - match (IT.bt t, cbt) with - | Bits _, Loc () -> - let addr = - if BT.equal (IT.bt t) Memory.uintptr_bt then smt_term - else bv_cast ~to_:Memory.uintptr_bt ~from:(IT.bt t) smt_term - in - CN_Pointer.bits_to_ptr ~bits:addr ~alloc_id:(default Alloc_id) - | Loc (), Bits _ -> - let maybe_cast x = - if BT.equal cbt Memory.uintptr_bt then x - else bv_cast ~to_:cbt ~from:Memory.uintptr_bt x - in - maybe_cast (CN_Pointer.addr_of ~ptr:smt_term) - | Loc (), Alloc_id -> - CN_Pointer.alloc_id_of ~ptr:smt_term ~null_case:(default Alloc_id) - | MemByte, Bits _ -> - let maybe_cast x = - if BT.equal cbt (BT.Bits (Unsigned, 8)) then x - else bv_cast ~to_:cbt ~from:(BT.Bits (Unsigned, 8)) x - in - maybe_cast (SMT.app_ CN_MemByte.value_name [ smt_term ]) - | MemByte, Alloc_id -> SMT.app_ CN_MemByte.alloc_id_name [ smt_term ] - | Real, Integer -> SMT.real_to_int smt_term - | Integer, Real -> SMT.int_to_real smt_term - | Bits _, Bits _ -> bv_cast ~to_:cbt ~from:(IT.bt t) smt_term - | _ -> assert false) + bv_cast + ~to_:(Memory.bt_of_sct (Sctypes.Integer ity)) + ~from:(IT.bt arg) + (translate_term s arg) + | Cast (cbt, t) -> + let smt_term = translate_term s t in + (match (IT.bt t, cbt) with + | Bits _, Loc () -> + let addr = + if BT.equal (IT.bt t) Memory.uintptr_bt then + smt_term + else + bv_cast ~to_:Memory.uintptr_bt ~from:(IT.bt t) smt_term + in + CN_Pointer.bits_to_ptr ~bits:addr ~alloc_id:(default Alloc_id) + | Loc (), Bits _ -> + let maybe_cast x = + if BT.equal cbt Memory.uintptr_bt then + x + else + bv_cast ~to_:cbt ~from:Memory.uintptr_bt x + in + maybe_cast (CN_Pointer.addr_of ~ptr:smt_term) + | Loc (), Alloc_id -> + CN_Pointer.alloc_id_of ~ptr:smt_term ~null_case:(default Alloc_id) + | MemByte, Bits _ -> + let maybe_cast x = + if BT.equal cbt (BT.Bits (Unsigned, 8)) then + x + else + bv_cast ~to_:cbt ~from:(BT.Bits (Unsigned, 8)) x + in + maybe_cast (SMT.app_ CN_MemByte.value_name [ smt_term ]) + | MemByte, Alloc_id -> SMT.app_ CN_MemByte.alloc_id_name [ smt_term ] + | Real, Integer -> SMT.real_to_int smt_term + | Integer, Real -> SMT.int_to_real smt_term + | Bits _, Bits _ -> bv_cast ~to_:cbt ~from:(IT.bt t) smt_term + | _ -> assert false) + (** Add an assertion. Quantified predicates are ignored. *) let add_assumption solver global lc = @@ -1002,12 +1091,13 @@ let add_assumption solver global lc = | T it -> ack_command solver (SMT.assume (translate_term s1 it)) | Forall _ -> () -type reduction = { - expr : SMT.sexp; (* translation of `it` *) - qs : (Sym.t * BT.t) list; (* quantifier instantiation *) - extra : SMT.sexp list (* additional assumptions *); -} + (** Goals are translated to this type *) +type reduction = + { expr : SMT.sexp; (* translation of `it` *) + qs : (Sym.t * BT.t) list; (* quantifier instantiation *) + extra : SMT.sexp list (* additional assumptions *) + } let translate_goal solver assumptions lc = let here = Locations.other __FUNCTION__ in @@ -1015,37 +1105,35 @@ let translate_goal solver assumptions lc = match lc with | T it -> { expr = translate_term solver it; qs = []; extra = [] } | Forall ((s, bt), it) -> - let v_s, v = IT.fresh_same bt s here in - let it = IT.subst (make_subst [ (s, v) ]) it in - { expr = translate_term solver it; qs = [ (v_s, bt) ]; extra = [] } + let v_s, v = IT.fresh_same bt s here in + let it = IT.subst (make_subst [ (s, v) ]) it in + { expr = translate_term solver it; qs = [ (v_s, bt) ]; extra = [] } in let add_asmps acc0 (s, bt) = let v = sym_ (s, bt, here) in let check_asmp lc acc = match lc with | Forall ((s', bt'), it') when BT.equal bt bt' -> - let new_asmp = IT.subst (make_subst [ (s', v) ]) it' in - translate_term solver new_asmp :: acc + let new_asmp = IT.subst (make_subst [ (s', v) ]) it' in + translate_term solver new_asmp :: acc | _ -> acc in LC.Set.fold check_asmp assumptions acc0 in { instantiated with extra = List.fold_left add_asmps [] instantiated.qs } + (* as similarly suggested by Robbert *) let shortcut simp_ctxt lc = let lc = Simplify.LogicalConstraints.simp simp_ctxt lc in - match lc with - | LC.T (IT (Const (Bool true), _, _)) -> `True - | _ -> `No_shortcut lc + match lc with LC.T (IT (Const (Bool true), _, _)) -> `True | _ -> `No_shortcut lc + (** {1 Solver Initialization} *) (** Declare a group of (possibly) mutually recursive datatypes *) let declare_datatype_group s names = - let mk_con_field (l, t) = - (CN_Names.datatype_field_name l, translate_base_type t) - in + let mk_con_field (l, t) = (CN_Names.datatype_field_name l, translate_base_type t) in let mk_con c = let ci = Sym.Map.find c s.globals.datatype_constrs in (CN_Names.datatype_con_name c, List.map mk_con_field ci.params) @@ -1057,19 +1145,21 @@ let declare_datatype_group s names = in ack_command s (SMT.declare_datatypes (List.map to_smt names)) + (** Declare a struct type and all struct types that it depends on. The `done_struct` keeps track of which structs we've already declared. *) let rec declare_struct s done_struct name decl = let mp = !done_struct in - if Sym.Set.mem name mp then () + if Sym.Set.mem name mp then + () else ( done_struct := Sym.Set.add name mp; let mk_field (l, t) = let rec declare_nested ty = match ty with | Struct name' -> - let decl = Sym.Map.find name' s.globals.struct_decls in - declare_struct s done_struct name' decl + let decl = Sym.Map.find name' s.globals.struct_decls in + declare_struct s done_struct name' decl | Map (_, el) -> declare_nested el | _ -> () in @@ -1077,15 +1167,15 @@ let rec declare_struct s done_struct name decl = declare_nested ty; (CN_Names.struct_field_name l, translate_base_type ty) in - let mk_piece (x : Memory.struct_piece) = - Option.map mk_field x.member_or_padding - in - ack_command s + let mk_piece (x : Memory.struct_piece) = Option.map mk_field x.member_or_padding in + ack_command + s (SMT.declare_datatype (CN_Names.struct_name name) [] [ (CN_Names.struct_con_name name, List.filter_map mk_piece decl) ])) + (** Declare various types always available to the solver. *) let declare_solver_basics s = for arity = 0 to 15 do @@ -1100,6 +1190,7 @@ let declare_solver_basics s = Sym.Map.iter (declare_struct s done_structs) s.globals.struct_decls; List.iter (declare_datatype_group s) (Option.get s.globals.datatype_order) + (* Logging *) module Logger = struct @@ -1109,6 +1200,7 @@ module Logger = struct let include_solver_responses = ref false let dir = ref (None : string option) + let log_counter = ref 0 (* Names of SMT files *) (** Pick a logger based on the above settings *) @@ -1120,39 +1212,34 @@ module Logger = struct match !dir with | Some dir -> dir | None -> - let nm = Printf.sprintf "cn_%.3f" (Unix.gettimeofday ()) in - let d = Filename.concat (Filename.get_temp_dir_name ()) nm in - dir := Some d; - d + let nm = Printf.sprintf "cn_%.3f" (Unix.gettimeofday ()) in + let d = Filename.concat (Filename.get_temp_dir_name ()) nm in + dir := Some d; + d in if not (Sys.file_exists dir) then Sys.mkdir dir 0o700 else (); - open_out - (Filename.concat dir (prefix ^ suf ^ string_of_int log_id ^ ".smt")) + open_out (Filename.concat dir (prefix ^ suf ^ string_of_int log_id ^ ".smt")) in - if !to_file then + if !to_file then ( let out = get_file "_send_" in if !include_solver_responses then - { - SMT.send = Printf.fprintf out "[->] %s\n%!"; + { SMT.send = Printf.fprintf out "[->] %s\n%!"; SMT.receive = Printf.fprintf out "[<-] %s\n%!"; - SMT.stop = (fun _ -> close_out out); + SMT.stop = (fun _ -> close_out out) } else - { - SMT.send = Printf.fprintf out "%s\n%!"; + { SMT.send = Printf.fprintf out "%s\n%!"; SMT.receive = (fun _ -> ()); - SMT.stop = (fun _ -> close_out out); - } + SMT.stop = (fun _ -> close_out out) + }) else - { - SMT.send = (fun _ -> ()); - SMT.receive = (fun _ -> ()); - SMT.stop = (fun _ -> ()); - } + { SMT.send = (fun _ -> ()); SMT.receive = (fun _ -> ()); SMT.stop = (fun _ -> ()) } end let solver_path = ref (None : string option) + let solver_type = ref (None : SMT.solver_extensions option) + let solver_flags = ref (None : string list option) (** Make a new solver instance *) @@ -1160,55 +1247,53 @@ let make globals = let cfg = ref (match !solver_type with - | Some t -> ( - match t with + | Some t -> + (match t with | SMT.Z3 -> SMT.z3 | SMT.CVC5 -> SMT.cvc5 | SMT.Other -> failwith "Unsupported solver.") - | None -> ( - match !solver_path with + | None -> + (match !solver_path with | None -> SMT.z3 - | Some path -> ( - match Filename.basename path with - | "z3" -> SMT.z3 - | "cvc5" -> SMT.cvc5 - | _ -> failwith "Please specify solver type"))) + | Some path -> + (match Filename.basename path with + | "z3" -> SMT.z3 + | "cvc5" -> SMT.cvc5 + | _ -> failwith "Please specify solver type"))) in - (match !solver_path with - | Some path -> cfg := { !cfg with SMT.exe = path } - | None -> ()); - (match !solver_flags with - | Some opts -> cfg := { !cfg with SMT.opts } - | None -> ()); - cfg := - { - !cfg with - log = - Logger.make - (match !cfg.exts with - | SMT.Z3 -> "z3" - | SMT.CVC5 -> "cvc5" - | SMT.Other -> "other"); - }; + (match !solver_path with Some path -> cfg := { !cfg with SMT.exe = path } | None -> ()); + (match !solver_flags with Some opts -> cfg := { !cfg with SMT.opts } | None -> ()); + cfg + := { !cfg with + log = + Logger.make + (match !cfg.exts with + | SMT.Z3 -> "z3" + | SMT.CVC5 -> "cvc5" + | SMT.Other -> "other") + }; let s = - { - smt_solver = SMT.new_solver !cfg; + { smt_solver = SMT.new_solver !cfg; cur_frame = ref (empty_solver_frame ()); prev_frames = ref []; name_seed = ref 0; - globals; + globals } in declare_solver_basics s; s + (* ---------------------------------------------------------------------------*) (* GLOBAL STATE: Models *) (* ---------------------------------------------------------------------------*) type model = int + type model_fn = IT.t -> IT.t option + type model_with_q = model * (Sym.t * BaseTypes.t) list + type model_table = (model, model_fn) Hashtbl.t let models_tbl : model_table = Hashtbl.create 1 @@ -1218,12 +1303,14 @@ let empty_model = Hashtbl.add models_tbl 0 model; 0 -type model_state = Model of model_with_q | No_model + +type model_state = + | Model of model_with_q + | No_model let model_state = ref No_model -let model () = - match !model_state with No_model -> assert false | Model mo -> mo +let model () = match !model_state with No_model -> assert false | Model mo -> mo (** Evaluate terms in the context of a model computed by the solver. *) let model_evaluator = @@ -1240,52 +1327,51 @@ let model_evaluator = match SMT.to_list mo with | None -> failwith "model is an atom" | Some defs -> - let scfg = solver.smt_solver.config in - let cfg = { scfg with log = Logger.make "model" } in - let smt_solver, new_solver = - match !model_evaluator_solver with - | Some smt_solver -> (smt_solver, false) - | None -> - let s = SMT.new_solver cfg in - model_evaluator_solver := Some s; - (s, true) - in - let model_id = new_model_id () in - let gs = solver.globals in - let evaluator = - { - smt_solver; - cur_frame = ref (empty_solver_frame ()); - prev_frames = - ref - (List.map copy_solver_frame - (!(solver.cur_frame) :: !(solver.prev_frames))) - (* We keep the prev_frames because things that were declared, would now be - defined by the model. Also, we need the infromation about the C type - mapping. *); - name_seed = solver.name_seed; - globals = gs; - } - in - if new_solver then ( - declare_solver_basics evaluator; - push evaluator); - let model_fn e = - if not (!currently_loaded_model = model_id) then ( - currently_loaded_model := model_id; - pop evaluator 1; - push evaluator; - List.iter (debug_ack_command evaluator) defs); - let inp = translate_term evaluator e in - match SMT.check smt_solver with - | SMT.Sat -> - let res = SMT.get_expr smt_solver inp in - let ctys = get_ctype_table evaluator in - Some (get_ivalue gs ctys (basetype e) (SMT.no_let res)) - | _ -> None - in - Hashtbl.add models_tbl model_id model_fn; - model_id + let scfg = solver.smt_solver.config in + let cfg = { scfg with log = Logger.make "model" } in + let smt_solver, new_solver = + match !model_evaluator_solver with + | Some smt_solver -> (smt_solver, false) + | None -> + let s = SMT.new_solver cfg in + model_evaluator_solver := Some s; + (s, true) + in + let model_id = new_model_id () in + let gs = solver.globals in + let evaluator = + { smt_solver; + cur_frame = ref (empty_solver_frame ()); + prev_frames = + ref + (List.map copy_solver_frame (!(solver.cur_frame) :: !(solver.prev_frames))) + (* We keep the prev_frames because things that were declared, would now be + defined by the model. Also, we need the infromation about the C type + mapping. *); + name_seed = solver.name_seed; + globals = gs + } + in + if new_solver then ( + declare_solver_basics evaluator; + push evaluator); + let model_fn e = + if not (!currently_loaded_model = model_id) then ( + currently_loaded_model := model_id; + pop evaluator 1; + push evaluator; + List.iter (debug_ack_command evaluator) defs); + let inp = translate_term evaluator e in + match SMT.check smt_solver with + | SMT.Sat -> + let res = SMT.get_expr smt_solver inp in + let ctys = get_ctype_table evaluator in + Some (get_ivalue gs ctys (basetype e) (SMT.no_let res)) + | _ -> None + in + Hashtbl.add models_tbl model_id model_fn; + model_id + (* ---------------------------------------------------------------------------*) @@ -1300,29 +1386,30 @@ let provable ~loc ~solver ~global ~assumptions ~simp_ctxt lc = in match shortcut simp_ctxt lc with | `True -> rtrue () - | `No_shortcut lc -> ( - let { expr; qs; extra } = translate_goal s1 assumptions lc in - let model_from sol = - let defs = SMT.get_model sol in - let mo = model_evaluator s1 defs in - model_state := Model (mo, qs) - in - let nlc = SMT.bool_not expr in - let inc = s1.smt_solver in - debug_ack_command s1 (SMT.push 1); - debug_ack_command s1 (SMT.assume (SMT.bool_ands (nlc :: extra))); - let res = SMT.check inc in - match res with - | SMT.Unsat -> - debug_ack_command s1 (SMT.pop 1); - rtrue () - | SMT.Sat -> - model_from inc; - debug_ack_command s1 (SMT.pop 1); - `False - | SMT.Unknown -> - debug_ack_command s1 (SMT.pop 1); - failwith "Unknown") + | `No_shortcut lc -> + let { expr; qs; extra } = translate_goal s1 assumptions lc in + let model_from sol = + let defs = SMT.get_model sol in + let mo = model_evaluator s1 defs in + model_state := Model (mo, qs) + in + let nlc = SMT.bool_not expr in + let inc = s1.smt_solver in + debug_ack_command s1 (SMT.push 1); + debug_ack_command s1 (SMT.assume (SMT.bool_ands (nlc :: extra))); + let res = SMT.check inc in + (match res with + | SMT.Unsat -> + debug_ack_command s1 (SMT.pop 1); + rtrue () + | SMT.Sat -> + model_from inc; + debug_ack_command s1 (SMT.pop 1); + `False + | SMT.Unknown -> + debug_ack_command s1 (SMT.pop 1); + failwith "Unknown") + (* let () = Z3.Solver.reset solver.non_incremental in let () = List.iter (fun lc -> Z3.Solver.add solver.non_incremental [lc] ) (nlc :: extra @ existing_scs) in let From 0ab06e042911936b240c13b4b13da2ec2741c08c Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Fri, 20 Dec 2024 22:36:44 +0000 Subject: [PATCH 120/148] CN: Assert max tuple size In the buddy allocator, tuples can end up being larger than 8, and so the error comes up as a solver rather than a more helpful arity one. This commit inserts a quick fix to make it fail at a better location. It does not come with a test because the buddy allocator is too large and slow to cut down, and I don't know how to coax Cerberus into generating tuples that big. --- backend/cn/lib/solver.ml | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 26ba9a622..07070eca3 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -230,9 +230,15 @@ let declare_bt_uninterpreted s (name, k) bt args_ts res_t = when we need them, with another piece of state in the solver to track which ones we have declared. *) module CN_Tuple = struct - let name arity = "cn_tuple_" ^ string_of_int arity + let max_arity = 15 + + let name arity = + assert (arity <= max_arity); + "cn_tuple_" ^ string_of_int arity + let selector arity field = + assert (arity <= max_arity); "cn_get_" ^ string_of_int field ^ "_of_" ^ string_of_int arity @@ -243,18 +249,21 @@ module CN_Tuple = struct (** Declare a datatype for a struct *) - let declare s arity = - let name = name arity in - let param i = "a" ^ string_of_int i in - let params = List.init arity param in - let field i = (selector arity i, SMT.atom (param i)) in - let fields = List.init arity field in - ack_command s (SMT.declare_datatype name params [ (name, fields) ]) + let declare s = + for arity = 0 to max_arity do + let name = name arity in + let param i = "a" ^ string_of_int i in + let params = List.init arity param in + let field i = (selector arity i, SMT.atom (param i)) in + let fields = List.init arity field in + ack_command s (SMT.declare_datatype name params [ (name, fields) ]) + done (** Make a tuple value *) let con es = let arity = List.length es in + assert (arity <= max_arity); SMT.app_ (name arity) es @@ -1178,9 +1187,7 @@ let rec declare_struct s done_struct name decl = (** Declare various types always available to the solver. *) let declare_solver_basics s = - for arity = 0 to 15 do - CN_Tuple.declare s arity - done; + CN_Tuple.declare s; CN_List.declare s; CN_MemByte.declare s; CN_Pointer.declare s; From 2a4793de91dcb1f42b1dbf98b70343b3094388a3 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 25 Dec 2024 14:08:46 +0000 Subject: [PATCH 121/148] CN: Rename IndexTerms getters These getters conflicted with the normal names for variables of that type, which leads to annoying and confusing error messages when the module is (frequently) opened, and leads to extra ' on the variable names to compensate. --- backend/cn/lib/alloc.ml | 2 +- backend/cn/lib/builtins.ml | 5 +- backend/cn/lib/cLogicalFuns.ml | 30 +-- backend/cn/lib/check.ml | 48 +++-- backend/cn/lib/cn_internal_to_ail.ml | 63 +++--- backend/cn/lib/compile.ml | 61 +++--- backend/cn/lib/context.ml | 2 +- backend/cn/lib/core_to_mucore.ml | 2 +- backend/cn/lib/diagnostics.ml | 19 +- backend/cn/lib/eqTable.ml | 2 +- backend/cn/lib/executable_spec_records.ml | 4 +- backend/cn/lib/explain.ml | 2 +- backend/cn/lib/indexTerms.ml | 137 +++++++------ backend/cn/lib/interval.ml | 8 +- backend/cn/lib/lemmata.ml | 28 +-- backend/cn/lib/logicalArgumentTypes.ml | 2 +- backend/cn/lib/logicalReturnTypes.ml | 2 +- backend/cn/lib/pack.ml | 14 +- backend/cn/lib/resourceInference.ml | 2 +- backend/cn/lib/simplify.ml | 36 ++-- backend/cn/lib/solver.ml | 34 ++-- backend/cn/lib/testGeneration/genBuiltins.ml | 12 +- backend/cn/lib/testGeneration/genCodeGen.ml | 2 +- backend/cn/lib/testGeneration/genCompile.ml | 8 +- .../cn/lib/testGeneration/genDistribute.ml | 7 +- backend/cn/lib/testGeneration/genNormalize.ml | 2 +- backend/cn/lib/testGeneration/genOptimize.ml | 12 +- backend/cn/lib/testGeneration/genTerms.ml | 2 +- backend/cn/lib/typeErrors.ml | 4 +- backend/cn/lib/typing.ml | 6 +- backend/cn/lib/wellTyped.ml | 188 +++++++++--------- 31 files changed, 387 insertions(+), 359 deletions(-) diff --git a/backend/cn/lib/alloc.ml b/backend/cn/lib/alloc.ml index 41ad3cb69..7de84e61d 100644 --- a/backend/cn/lib/alloc.ml +++ b/backend/cn/lib/alloc.ml @@ -23,7 +23,7 @@ module History = struct let it loc' = IndexTerms.sym_ (sym, bt, loc') let lookup_ptr ptr loc' = - assert (BaseTypes.(equal (IndexTerms.bt ptr) (Loc ()))); + assert (BaseTypes.(equal (IndexTerms.get_bt ptr) (Loc ()))); IndexTerms.(map_get_ (it loc') (allocId_ ptr loc') loc') diff --git a/backend/cn/lib/builtins.ml b/backend/cn/lib/builtins.ml index b83f0ad82..87d90d6f5 100644 --- a/backend/cn/lib/builtins.ml +++ b/backend/cn/lib/builtins.ml @@ -122,14 +122,15 @@ let array_to_list_def = ( "array_to_list", Sym.fresh_named "array_to_list", mk_arg3_err (fun (arr, i, len) loc -> - match SBT.is_map_bt (IT.bt arr) with + match SBT.is_map_bt (IT.get_bt arr) with | None -> let reason = "map/array operation" in let expected = "map/array" in fail { loc; msg = - Illtyped_it { it = IT.pp arr; has = SBT.pp (IT.bt arr); expected; reason } + Illtyped_it + { it = IT.pp arr; has = SBT.pp (IT.get_bt arr); expected; reason } } | Some (_, bt) -> return (array_to_list_ (arr, i, len) bt loc)) ) diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index fde6f7448..33e003b27 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -81,7 +81,7 @@ let triv_simp_ctxt = Simplify.default Global.empty let simp_const loc lpp it = let it2 = Simplify.IndexTerms.simp triv_simp_ctxt it in - match (IT.is_z it2, IT.bt it2) with + match (IT.is_z it2, IT.get_bt it2) with | Some _z, _ -> return it2 | _, BT.Integer -> fail_n @@ -99,7 +99,7 @@ let do_wrapI loc ct it = match Sctypes.is_integer_type ct with | Some ity -> let ity_bt = Memory.bt_of_sct ct in - if BT.equal ity_bt (IT.bt it) then + if BT.equal ity_bt (IT.get_bt it) then return it else return (IT.wrapI_ (ity, it) loc) @@ -166,13 +166,13 @@ let signed_int_ity = Sctypes.(IntegerTypes.Signed IntegerBaseTypes.Int_) let signed_int_ty = Memory.bt_of_sct (Sctypes.Integer signed_int_ity) let is_two_pow it = - match IT.term it with + match IT.get_term it with | Terms.Binop (Terms.ExpNoSMT, x, y) when Option.equal Z.equal (IT.get_num_z x) (Some (Z.of_int 2)) -> - Some (`Two_loc (IT.loc x), `Exp y) + Some (`Two_loc (IT.get_loc x), `Exp y) | Terms.Binop (Terms.Exp, x, y) when Option.equal Z.equal (IT.get_num_z x) (Some (Z.of_int 2)) -> - Some (`Two_loc (IT.loc x), `Exp y) + Some (`Two_loc (IT.get_loc x), `Exp y) | _ -> None @@ -307,13 +307,13 @@ let rec symb_exec_pexpr ctxt var_map pexpr = in (match (op, x_v, is_two_pow y_v) with | OpMul, _, Some (`Two_loc two_loc, `Exp exp) -> - let exp_loc = IT.loc y_v in + let exp_loc = IT.get_loc y_v in return - (IT.mul_ (x_v, IT.exp_ (IT.int_lit_ 2 (IT.bt x_v) two_loc, exp) exp_loc) loc) + (IT.mul_ (x_v, IT.exp_ (IT.int_lit_ 2 (IT.get_bt x_v) two_loc, exp) exp_loc) loc) | OpDiv, _, Some (`Two_loc two_loc, `Exp exp) -> - let exp_loc = IT.loc y_v in + let exp_loc = IT.get_loc y_v in return - (IT.div_ (x_v, IT.exp_ (IT.int_lit_ 2 (IT.bt x_v) two_loc, exp) exp_loc) loc) + (IT.div_ (x_v, IT.exp_ (IT.int_lit_ 2 (IT.get_bt x_v) two_loc, exp) exp_loc) loc) | _, _, _ -> let@ res = simp_const_pe (f x_v y_v) in return res) @@ -364,7 +364,7 @@ let rec symb_exec_pexpr ctxt var_map pexpr = simp_const_pe (bool_ite_1_0 bool_rep_ty - (IT.not_ (IT.eq_ (x, IT.int_lit_ 0 (IT.bt x) here) here) here) + (IT.not_ (IT.eq_ (x, IT.int_lit_ 0 (IT.get_bt x) here) here) here) loc) | _ -> do_wrapI loc ct x) | PEwrapI (act, pe) -> @@ -382,8 +382,8 @@ let rec symb_exec_pexpr ctxt var_map pexpr = | IOpAdd -> IT.add_ (x, y) loc | IOpSub -> IT.sub_ (x, y) loc | IOpMul -> IT.mul_ (x, y) loc - | IOpShl -> IT.arith_binop Terms.ShiftLeft (x, IT.cast_ (IT.bt x) y here) loc - | IOpShr -> IT.arith_binop Terms.ShiftRight (x, IT.cast_ (IT.bt x) y here) loc + | IOpShl -> IT.arith_binop Terms.ShiftLeft (x, IT.cast_ (IT.get_bt x) y here) loc + | IOpShr -> IT.arith_binop Terms.ShiftRight (x, IT.cast_ (IT.get_bt x) y here) loc in do_wrapI loc (Mu.bound_kind_act bk).ct it | PEcfunction pe -> @@ -590,7 +590,7 @@ let rec filter_syms ss p = let rec get_ret_it loc body bt = function | Call_Ret v -> let@ () = - if BT.equal (IT.bt v) bt then + if BT.equal (IT.get_bt v) bt then return () else fail_n @@ -642,7 +642,7 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ let rec mk_var_map acc args_and_body def_args = match (args_and_body, def_args) with | Mu.Computational ((s, bt), _, args_and_body), v :: def_args -> - if BT.equal bt (IT.bt v) then + if BT.equal bt (IT.get_bt v) then mk_var_map (Sym.Map.add s v acc) args_and_body def_args else fail_n @@ -651,7 +651,7 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ Generic Pp.( !^"mismatched arguments:" - ^^^ parens (BT.pp (IT.bt v) ^^^ IT.pp v) + ^^^ parens (BT.pp (IT.get_bt v) ^^^ IT.pp v) ^^^ !^"and" ^^^ parens (BT.pp bt ^^^ Sym.pp s)) } diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index aaa448c41..c77a261c8 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -269,7 +269,7 @@ let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = (* try to follow is_representable_integer from runtime/libcore/std.core *) let is_representable_integer arg ity = let here = Locations.other __FUNCTION__ in - let bt = IT.bt arg in + let bt = IT.get_bt arg in let arg_bits = Option.get (BT.is_bits_bt bt) in let maxInt = Memory.max_integer_type ity in assert (BT.fits_range arg_bits maxInt); @@ -384,7 +384,7 @@ let check_conv_int loc ~expect ct arg = fail (fun ctxt -> { loc; msg = Int_unrepresentable { value = arg; ict = ct; ctxt; model } }) in - let bt = IT.bt arg in + let bt = IT.get_bt arg in (* TODO: can we (later) optimise this? *) let here = Locations.other __FUNCTION__ in let@ value = @@ -513,7 +513,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ () = WellTyped.ensure_base_type loc ~expect bt in k (sym_ (sym, bt, loc)) | Value lvt -> - let@ () = WellTyped.ensure_base_type loc ~expect (IT.bt lvt) in + let@ () = WellTyped.ensure_base_type loc ~expect (IT.get_bt lvt) in k lvt) | PEval v -> let@ () = ensure_base_type loc ~expect (Mu.bt_of_value v) in @@ -826,7 +826,9 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> - let arg1_bt_range = BT.bits_range (Option.get (BT.is_bits_bt (IT.bt arg1))) in + let arg1_bt_range = + BT.bits_range (Option.get (BT.is_bits_bt (IT.get_bt arg1))) + in let here = Locations.other __FUNCTION__ in let arg2_bits_lost = IT.not_ (IT.in_z_range arg2 arg1_bt_range here) here in let x = @@ -838,13 +840,17 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = ite_ ( arg2_bits_lost, IT.int_lit_ 0 expect loc, - arith_binop Terms.ShiftLeft (arg1, cast_ (IT.bt arg1) arg2 loc) loc ) + arith_binop Terms.ShiftLeft (arg1, cast_ (IT.get_bt arg1) arg2 loc) loc + ) loc | IOpShr -> ite_ ( arg2_bits_lost, IT.int_lit_ 0 expect loc, - arith_binop Terms.ShiftRight (arg1, cast_ (IT.bt arg1) arg2 loc) loc ) + arith_binop + Terms.ShiftRight + (arg1, cast_ (IT.get_bt arg1) arg2 loc) + loc ) loc in k x)) @@ -875,11 +881,11 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | IOpMul -> (mul_ (arg1, arg2) loc, mul_ (large arg1, large arg2) loc, bool_ true here) | IOpShl -> - ( arith_binop Terms.ShiftLeft (arg1, cast_ (IT.bt arg1) arg2 loc) loc, + ( arith_binop Terms.ShiftLeft (arg1, cast_ (IT.get_bt arg1) arg2 loc) loc, arith_binop Terms.ShiftLeft (large arg1, large arg2) loc, IT.in_z_range arg2 (Z.zero, Z.of_int bits) loc ) | IOpShr -> - ( arith_binop Terms.ShiftRight (arg1, cast_ (IT.bt arg1) arg2 loc) loc, + ( arith_binop Terms.ShiftRight (arg1, cast_ (IT.get_bt arg1) arg2 loc) loc, arith_binop Terms.ShiftRight (large arg1, large arg2) loc, IT.in_z_range arg2 (Z.zero, Z.of_int bits) loc ) in @@ -1229,8 +1235,8 @@ let load loc pointer ct = let instantiate loc filter arg = let arg_s = Sym.fresh_make_uniq "instance" in - let arg_it = sym_ (arg_s, IT.bt arg, loc) in - let@ () = add_l arg_s (IT.bt arg_it) (loc, lazy (Sym.pp arg_s)) in + let arg_it = sym_ (arg_s, IT.get_bt arg, loc) in + let@ () = add_l arg_s (IT.get_bt arg_it) (loc, lazy (Sym.pp arg_s)) in let@ () = add_c loc (LC.T (eq__ arg_it arg loc)) in let@ constraints = get_cs () in let extra_assumptions1 = @@ -1239,7 +1245,7 @@ let instantiate loc filter arg = (LC.Set.elements constraints) in let extra_assumptions2, type_mismatch = - List.partition (fun ((_, bt), _) -> BT.equal bt (IT.bt arg_it)) extra_assumptions1 + List.partition (fun ((_, bt), _) -> BT.equal bt (IT.get_bt arg_it)) extra_assumptions1 in let extra_assumptions = List.map @@ -1256,7 +1262,7 @@ let instantiate loc filter arg = Pp.warn loc (!^"did not instantiate on basetype mismatch:" - ^^^ Pp.list BT.pp [ bt; IT.bt arg_it ])) + ^^^ Pp.list BT.pp [ bt; IT.get_bt arg_it ])) type_mismatch; add_cs loc extra_assumptions @@ -1488,7 +1494,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = check_pexpr pe (fun arg -> let sym, result = IT.fresh_named (BT.Loc ()) "intToPtr" loc in let@ _ = add_a sym (Loc ()) (here, lazy (Sym.pp sym)) in - let cond = eq_ (arg, int_lit_ 0 (bt arg) here) here in + let cond = eq_ (arg, int_lit_ 0 (get_bt arg) here) here in let null_case = eq_ (result, null_ here) here in (* NOTE: the allocation ID is intentionally left unconstrained *) let alloc_case = @@ -1598,7 +1604,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = IT.fresh_named (BT.Loc ()) ("&ARG" ^ string_of_int n) loc | _ -> IT.fresh (BT.Loc ()) loc in - let@ () = add_a ret_s (IT.bt ret) (loc, lazy (Pp.string "allocation")) in + let@ () = add_a ret_s (IT.get_bt ret) (loc, lazy (Pp.string "allocation")) in (* let@ () = add_c loc (LC.T (representable_ (Pointer act.ct, ret) loc)) in *) let align_v = cast_ Memory.uintptr_bt arg loc in let@ () = add_c loc (LC.T (alignedI_ ~align:align_v ~t:ret loc)) in @@ -1810,7 +1816,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = match ct with | Sctypes.Void | Array (_, _) | Struct _ | Function (_, _, _) -> assert false | Integer it -> - let bt = IT.bt value in + let bt = IT.get_bt value in let lhs = value in let rhs = let[@ocaml.warning "-8"] (b :: bytes) = @@ -2096,7 +2102,7 @@ let check_expr_top loc labels rt e = let bind_arguments (_loc : Locations.t) (full_args : _ Mu.arguments) = let rec aux_l resources = function | Mu.Define ((s, it), ((loc, _) as info), args) -> - let@ () = add_l s (IT.bt it) (fst info, lazy (Sym.pp s)) in + let@ () = add_l s (IT.get_bt it) (fst info, lazy (Sym.pp s)) in let@ () = add_c (fst info) (LC.T (def_ s it loc)) in aux_l resources args | Constraint (lc, info, args) -> @@ -2484,19 +2490,21 @@ let ctz_proxy_ft = let info = (here, Some "ctz_proxy builtin ft") in let n_sym, n = IT.fresh_named BT.(Bits (Unsigned, 32)) "n_" here in let ret_sym, ret = IT.fresh_named BT.(Bits (Signed, 32)) "return" here in - let neq_0 = LC.T (IT.not_ (IT.eq_ (n, IT.int_lit_ 0 (IT.bt n) here) here) here) in + let neq_0 = LC.T (IT.not_ (IT.eq_ (n, IT.int_lit_ 0 (IT.get_bt n) here) here) here) in let eq_ctz = LC.T (IT.eq_ - (ret, cast_ (IT.bt ret) (IT.arith_unop Terms.BW_CTZ_NoSMT n here) here) + (ret, cast_ (IT.get_bt ret) (IT.arith_unop Terms.BW_CTZ_NoSMT n here) here) here) in let rt = - RT.mComputational ((ret_sym, IT.bt ret), info) (LRT.mConstraint (eq_ctz, info) LRT.I) + RT.mComputational + ((ret_sym, IT.get_bt ret), info) + (LRT.mConstraint (eq_ctz, info) LRT.I) in let ft = AT.mComputationals - [ (n_sym, IT.bt n, info) ] + [ (n_sym, IT.get_bt n, info) ] (AT.L (LAT.mConstraint (neq_0, info) (LAT.I rt))) in ft diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 9aec367f4..7a8b91af5 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -841,15 +841,15 @@ let rec cn_to_ail_expr_aux_internal in (* let is_map it = - match IT.bt it with + match IT.get_bt it with | BT.Map (bt1, bt2) -> - Printf.printf "Type of %s: Map(%s, %s)\n" (str_of_it_ (IT.term it)) (str_of_ctype (bt_to_ail_ctype bt1)) (str_of_ctype (bt_to_ail_ctype bt2)); + Printf.printf "Type of %s: Map(%s, %s)\n" (str_of_it_ (IT.get_term it)) (str_of_ctype (bt_to_ail_ctype bt1)) (str_of_ctype (bt_to_ail_ctype bt2)); true | _ -> false in *) let ail_expr_ = match ail_bop with - | Eq -> get_equality_fn_call (IT.bt t1) e1 e2 dts + | Eq -> get_equality_fn_call (IT.get_bt t1) e1 e2 dts | _ -> default_ail_binop in dest d (b1 @ b2, s1 @ s2, mk_expr ail_expr_) @@ -857,7 +857,7 @@ let rec cn_to_ail_expr_aux_internal let b, s, e = cn_to_ail_expr_aux_internal const_prop pred_name dts globals t PassBack in - let _ail_unop, annot = cn_to_ail_unop_internal (IT.bt t) unop in + let _ail_unop, annot = cn_to_ail_unop_internal (IT.get_bt t) unop in let str = match annot with Some str -> str | None -> failwith "No CN unop function found" in @@ -871,7 +871,7 @@ let rec cn_to_ail_expr_aux_internal | ITE (t1, t2, t3) -> let result_sym = Sym.fresh () in let result_ident = A.(AilEident result_sym) in - let result_binding = create_binding result_sym (bt_to_ail_ctype (IT.bt t2)) in + let result_binding = create_binding result_sym (bt_to_ail_ctype (IT.get_bt t2)) in let result_decl = A.(AilSdeclaration [ (result_sym, None) ]) in let b1, s1, e1 = cn_to_ail_expr_aux_internal const_prop pred_name dts globals t1 PassBack @@ -987,7 +987,7 @@ let rec cn_to_ail_expr_aux_internal dest d (b, s, mk_expr ail_expr_) | StructUpdate ((struct_term, m), new_val) -> let struct_tag = - match IT.bt struct_term with + match IT.get_bt struct_term with | BT.Struct tag -> tag | _ -> failwith "Cannot do StructUpdate on non-struct term" in @@ -1048,7 +1048,7 @@ let rec cn_to_ail_expr_aux_internal let assign_stat = A.(AilSexpr (mk_expr (AilEassign (mk_expr ail_memberof, e)))) in (b, s, assign_stat) in - let transformed_ms = List.map (fun (id, it) -> (id, IT.bt it)) ms in + let transformed_ms = List.map (fun (id, it) -> (id, IT.get_bt it)) ms in let sym_name = lookup_records_map transformed_ms in let ctype_ = C.(Pointer (empty_qualifiers, mk_ctype (Struct sym_name))) in let res_binding = create_binding res_sym (mk_ctype ctype_) in @@ -1199,7 +1199,7 @@ let rec cn_to_ail_expr_aux_internal cn_to_ail_expr_aux_internal const_prop pred_name dts globals m PassBack in let key_term = - if IT.bt key == BT.Integer then + if IT.get_bt key == BT.Integer then key else IT.IT (Cast (BT.Integer, key), BT.Integer, Cerb_location.unknown) @@ -1211,7 +1211,7 @@ let rec cn_to_ail_expr_aux_internal cn_to_ail_expr_aux_internal const_prop pred_name dts globals value PassBack in let new_map_sym = Sym.fresh () in - let new_map_binding = create_binding new_map_sym (bt_to_ail_ctype (IT.bt m)) in + let new_map_binding = create_binding new_map_sym (bt_to_ail_ctype (IT.get_bt m)) in let map_deep_copy_fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty "cn_map_deep_copy")), [ e1 ])) in @@ -1235,7 +1235,7 @@ let rec cn_to_ail_expr_aux_internal cn_to_ail_expr_aux_internal const_prop pred_name dts globals m PassBack in let key_term = - if IT.bt key == BT.Integer then + if IT.get_bt key == BT.Integer then key else IT.IT (Cast (BT.Integer, key), BT.Integer, Cerb_location.unknown) @@ -1243,7 +1243,9 @@ let rec cn_to_ail_expr_aux_internal let b2, s2, e2 = cn_to_ail_expr_aux_internal const_prop pred_name dts globals key_term PassBack in - let is_record = match BT.map_bt (IT.bt m) with _, Record _ -> true | _ -> false in + let is_record = + match BT.map_bt (IT.get_bt m) with _, Record _ -> true | _ -> false + in let cntype_str_opt = get_underscored_typedef_string_from_bt ~is_record basetype in let map_get_str = match cntype_str_opt with @@ -1253,7 +1255,7 @@ let rec cn_to_ail_expr_aux_internal let map_get_fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty map_get_str)), [ e1; e2 ])) in - let _key_bt, val_bt = BT.map_bt (IT.bt m) in + let _key_bt, val_bt = BT.map_bt (IT.get_bt m) in let ctype = bt_to_ail_ctype val_bt in let cast_expr_ = A.(AilEcast (empty_qualifiers, ctype, mk_expr map_get_fcall)) in dest d (b1 @ b2, s1 @ s2, mk_expr cast_expr_) @@ -1277,7 +1279,7 @@ let rec cn_to_ail_expr_aux_internal let b1, s1, e1 = cn_to_ail_expr_aux_internal const_prop pred_name dts globals t1 PassBack in - let ctype = bt_to_ail_ctype (IT.bt t1) in + let ctype = bt_to_ail_ctype (IT.get_bt t1) in let binding = create_binding var ctype in let ail_assign = A.(AilSdeclaration [ (var, Some e1) ]) in prefix @@ -1348,7 +1350,7 @@ let rec cn_to_ail_expr_aux_internal let bindings', stats' = translate count vs cases res_sym_opt in (bindings', stats')) else ( - match IT.bt term with + match IT.get_bt term with | BT.Datatype sym -> let cn_dt = List.filter (fun dt -> Sym.equal sym dt.cn_dt_name) dts in (match cn_dt with @@ -1438,7 +1440,7 @@ let rec cn_to_ail_expr_aux_internal (b1, s1 @ [ switch ])) | _ -> (* Cannot have non-variable, non-wildcard pattern besides struct *) - let bt_string_opt = get_typedef_string (bt_to_ail_ctype (IT.bt term)) in + let bt_string_opt = get_typedef_string (bt_to_ail_ctype (IT.get_bt term)) in let bt_string = match bt_string_opt with | Some str -> str @@ -1480,7 +1482,7 @@ let rec cn_to_ail_expr_aux_internal let ail_expr_ = match ( get_typedef_string (bt_to_ail_ctype bt), - get_typedef_string (bt_to_ail_ctype (IT.bt t)) ) + get_typedef_string (bt_to_ail_ctype (IT.get_bt t)) ) with | Some cast_type_str, Some original_type_str -> let fn_name = "cast_" ^ original_type_str ^ "_to_" ^ cast_type_str in @@ -2500,12 +2502,15 @@ let get_while_bounds_and_cond (i_sym, i_bt) it = plain (Pp.item "Cannot infer lower bound for permission" - (squotes (IT.pp it) ^^^ !^"at" ^^^ Locations.pp (IT.loc it))))) + (squotes (IT.pp it) ^^^ !^"at" ^^^ Locations.pp (IT.get_loc it))))) (); exit 2) in let start_expr = - IT.IT (IT.Cast (IT.bt start_expr, start_expr), IT.bt start_expr, Cerb_location.unknown) + IT.IT + ( IT.Cast (IT.get_bt start_expr, start_expr), + IT.get_bt start_expr, + Cerb_location.unknown ) in let start_cond = match start_expr with @@ -2526,7 +2531,7 @@ let get_while_bounds_and_cond (i_sym, i_bt) it = plain (Pp.item "Cannot infer upper bound for permission" - (squotes (IT.pp it) ^^^ !^"at" ^^^ Locations.pp (IT.loc it))))) + (squotes (IT.pp it) ^^^ !^"at" ^^^ Locations.pp (IT.get_loc it))))) (); exit 2 in @@ -2846,11 +2851,11 @@ let cn_to_ail_logical_constraint_internal | LogicalConstraints.T it -> cn_to_ail_expr_internal dts globals it d | LogicalConstraints.Forall ((sym, bt), it) -> let cond_it, t = - match IT.term it with + match IT.get_term it with | Binop (Implies, it, it') -> (it, it') | _ -> failwith "Incorrect form of forall logical constraint term" in - (match IT.term t with + (match IT.get_term t with | Good _ -> dest d ([], [], cn_bool_true_expr) | _ -> (* Assume cond_it is of a particular form *) @@ -2986,7 +2991,7 @@ let cn_to_ail_function_internal let rec cn_to_ail_lat_internal ?(is_toplevel = true) dts pred_sym_opt globals preds = function | LAT.Define ((name, it), _info, lat) -> - let ctype = bt_to_ail_ctype (IT.bt it) in + let ctype = bt_to_ail_ctype (IT.get_bt it) in let binding = create_binding name ctype in let decl = A.(AilSdeclaration [ (name, None) ]) in let b1, s1 = @@ -3129,8 +3134,10 @@ let rec cn_to_ail_post_aux_internal dts globals preds = function | LRT.Define ((name, it), (_loc, _), t) -> (* Printf.printf "LRT.Define\n"; *) let new_name = generate_sym_with_suffix ~suffix:"_cn" name in - let new_lrt = LogicalReturnTypes.subst (ESE.sym_subst (name, IT.bt it, new_name)) t in - let binding = create_binding new_name (bt_to_ail_ctype (IT.bt it)) in + let new_lrt = + LogicalReturnTypes.subst (ESE.sym_subst (name, IT.get_bt it, new_name)) t + in + let binding = create_binding new_name (bt_to_ail_ctype (IT.get_bt it)) in let decl = A.(AilSdeclaration [ (new_name, None) ]) in let b1, s1 = cn_to_ail_expr_internal dts globals it (AssignVar new_name) in let b2, s2 = cn_to_ail_post_aux_internal dts globals preds new_lrt in @@ -3263,10 +3270,10 @@ let rec cn_to_ail_lat_internal_2 c_return_type = function | LAT.Define ((name, it), _info, lat) -> - let ctype = bt_to_ail_ctype (IT.bt it) in + let ctype = bt_to_ail_ctype (IT.get_bt it) in let new_name = generate_sym_with_suffix ~suffix:"_cn" name in let new_lat = - ESE.fn_largs_and_body_subst (ESE.sym_subst (name, IT.bt it, new_name)) lat + ESE.fn_largs_and_body_subst (ESE.sym_subst (name, IT.get_bt it, new_name)) lat in (* let ctype = mk_ctype C.(Pointer (empty_qualifiers, ctype)) in *) let binding = create_binding new_name ctype in @@ -3818,7 +3825,7 @@ let cn_to_ail_assume_resource_internal let rec cn_to_ail_assume_lat_internal dts pred_sym_opt globals preds = function | LAT.Define ((name, it), _info, lat) -> - let ctype = bt_to_ail_ctype (IT.bt it) in + let ctype = bt_to_ail_ctype (IT.get_bt it) in let binding = create_binding name ctype in let decl = A.(AilSdeclaration [ (name, None) ]) in let b1, s1 = @@ -3918,7 +3925,7 @@ let rec cn_to_ail_assume_predicates_internal pred_def_list dts globals preds let rec cn_to_ail_assume_lat_internal_2 dts pred_sym_opt globals preds = function | LAT.Define ((name, it), _info, lat) -> - let ctype = bt_to_ail_ctype (IT.bt it) in + let ctype = bt_to_ail_ctype (IT.get_bt it) in let binding = create_binding name ctype in let decl = A.(AilSdeclaration [ (name, None) ]) in let b1, s1 = diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 7a6c01b07..4fb14020e 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -449,9 +449,9 @@ module EffectfulTranslation = struct let mk_translate_binop loc' bop (e1, e2) = let open IndexTerms in let loc = loc' in - match (bop, IT.bt e1) with + match (bop, IT.get_bt e1) with | CN_add, (BT.Integer | Real | Bits _) -> - return (IT (Binop (Add, e1, e2), IT.bt e1, loc)) + return (IT (Binop (Add, e1, e2), IT.get_bt e1, loc)) | CN_add, Loc oct -> (match oct with | Some ct -> @@ -462,7 +462,7 @@ module EffectfulTranslation = struct return (IT (it_, Loc oct, loc)) | None -> cannot_tell_pointee_ctype loc e1) | CN_sub, (Integer | Real | Bits _) -> - return (IT (Binop (Sub, e1, e2), IT.bt e1, loc)) + return (IT (Binop (Sub, e1, e2), IT.get_bt e1, loc)) | CN_sub, Loc oct -> (match oct with | Some ct -> @@ -477,11 +477,11 @@ module EffectfulTranslation = struct in return (IT (it_, Loc oct, loc)) | None -> cannot_tell_pointee_ctype loc e1) - | CN_mul, _ -> return (IT (Binop (Mul, e1, e2), IT.bt e1, loc)) - | CN_div, _ -> return (IT (Binop (Div, e1, e2), IT.bt e1, loc)) - | CN_mod, _ -> return (IT (Binop (Rem, e1, e2), IT.bt e1, loc)) + | CN_mul, _ -> return (IT (Binop (Mul, e1, e2), IT.get_bt e1, loc)) + | CN_div, _ -> return (IT (Binop (Div, e1, e2), IT.get_bt e1, loc)) + | CN_mod, _ -> return (IT (Binop (Rem, e1, e2), IT.get_bt e1, loc)) | CN_equal, _ -> - (match (IT.bt e1, IT.bt e2, !pointer_eq_warned) with + (match (IT.get_bt e1, IT.get_bt e2, !pointer_eq_warned) with | Loc _, Loc _, false -> pointer_eq_warned := true; Pp.warn @@ -491,7 +491,7 @@ module EffectfulTranslation = struct | _, _, _ -> ()); return (IT (Binop (EQ, e1, e2), BT.Bool, loc)) | CN_inequal, _ -> - (match (IT.bt e1, IT.bt e2, !pointer_eq_warned) with + (match (IT.get_bt e1, IT.get_bt e2, !pointer_eq_warned) with | Loc _, Loc _, false -> pointer_eq_warned := true; Pp.warn @@ -517,7 +517,7 @@ module EffectfulTranslation = struct | CN_implies, BT.Bool -> return (IT (Binop (Implies, e1, e2), BT.Bool, loc)) | CN_map_get, _ -> let@ rbt = - match IT.bt e1 with + match IT.get_bt e1 with | Map (_, rbt) -> return rbt | has -> let expected = "map/array" in @@ -536,7 +536,7 @@ module EffectfulTranslation = struct (* just copy-pasting and adapting Kayvan's older version of this code *) let translate_member_access loc env (t : IT.Surface.t) member = - match IT.bt t with + match IT.get_bt t with | BT.Record members -> let@ member_bt = match List.assoc_opt Id.equal member members with @@ -657,7 +657,7 @@ module EffectfulTranslation = struct Option.get @@ Locations.get_region loc in let cons hd tl = - let hd_pos = Option.get @@ Locations.start_pos @@ IT.loc hd in + let hd_pos = Option.get @@ Locations.start_pos @@ IT.get_loc hd in let loc = Locations.(region (hd_pos, nil_pos) NoCursor) in IT (Cons (hd, tl), BT.List item_bt, loc) in @@ -675,16 +675,16 @@ module EffectfulTranslation = struct translate_member_access loc env e xs | CNExpr_record members -> let@ members = ListM.mapsndM self members in - let bts = List.map_snd IT.bt members in + let bts = List.map_snd IT.get_bt members in return (IT (IT.Record members, BT.Record bts, loc)) | CNExpr_struct (tag, members) -> let@ members = ListM.mapsndM self members in return (IT (IT.Struct (tag, members), BT.Struct tag, loc)) | CNExpr_memberupdates (e, updates) -> let@ e = self e in - let bt = IT.bt e in + let bt = IT.get_bt e in let end_pos = Option.get @@ Locations.end_pos loc in - (match IT.bt e with + (match IT.get_bt e with | Struct _ -> let@ expr = ListM.fold_rightM @@ -700,7 +700,7 @@ module EffectfulTranslation = struct return expr | _ -> fail - { loc = IT.loc e; + { loc = IT.get_loc e; msg = Illtyped_it { it = Terms.pp e; @@ -713,7 +713,7 @@ module EffectfulTranslation = struct }) | CNExpr_arrayindexupdates (e, updates) -> let@ e = self e in - let bt = IT.bt e in + let bt = IT.get_bt e in (* start_pos points to start_pos of e ignored cursor points to '[' end_pos points to ']' *) let start_pos, end_pos, _ = @@ -725,10 +725,11 @@ module EffectfulTranslation = struct (fun acc (i, v) -> let@ i = self i in let@ v = self v in - let end_pos = Option.get @@ Locations.end_pos @@ IT.loc v in + let end_pos = Option.get @@ Locations.end_pos @@ IT.get_loc v in (* cursor for the first update doesn't point to '[' - oh well *) let cursor = - Cerb_location.PointCursor (Option.get @@ Locations.start_pos @@ IT.loc i) + Cerb_location.PointCursor + (Option.get @@ Locations.start_pos @@ IT.get_loc i) in return (IT @@ -756,7 +757,7 @@ module EffectfulTranslation = struct | CNExpr_array_shift (base, ty_annot, index) -> let@ base = self base in let@ ct = - match (ty_annot, IT.bt base) with + match (ty_annot, IT.get_bt base) with | Some ty, _ -> (* this does not check whether the annotation and pointer type agree and just defers to what the user wrote, because pointer arithmetic can happen at any @@ -772,10 +773,10 @@ module EffectfulTranslation = struct pointer" } in - (match IT.bt base with + (match IT.get_bt base with | Loc _ -> let@ index = self index in - (match IT.bt index with + (match IT.get_bt index with | Integer | Bits _ -> return (IT (ArrayShift { base; ct; index }, Loc (Some ct), loc)) | has -> @@ -807,7 +808,7 @@ module EffectfulTranslation = struct now. *) return (IT (it_, Loc (Some member_ty), loc)) in - (match (opt_tag, IT.bt e) with + (match (opt_tag, IT.get_bt e) with | Some tag, Loc (Some (Struct tag')) -> if Sym.equal tag tag' then with_tag tag @@ -878,7 +879,7 @@ module EffectfulTranslation = struct ListM.mapM (fun (pat, body) -> let@ env', locally_bound', pat = - translate_cn_pat env locally_bound (pat, IT.bt x) + translate_cn_pat env locally_bound (pat, IT.get_bt x) in let@ body = trans evaluation_scope locally_bound' env' body in return (pat, body)) @@ -892,10 +893,10 @@ module EffectfulTranslation = struct trans evaluation_scope (Sym.Set.add s locally_bound) - (add_logical s (IT.bt e) env) + (add_logical s (IT.get_bt e) env) body in - return (IT (Let ((s, e), body), IT.bt body, loc)) + return (IT (Let ((s, e), body), IT.get_bt body, loc)) | CNExpr_ite (e1, e2, e3) -> let@ e1 = self e1 in let@ e2 = self e2 in @@ -1025,7 +1026,7 @@ module EffectfulTranslation = struct match oty with | Some ty -> return (Sctypes.of_ctype_unsafe res_loc ty) | None -> - (match IT.bt ptr_expr with + (match IT.get_bt ptr_expr with | BT.Loc (Some ty) -> return ty | Loc None -> fail @@ -1076,7 +1077,7 @@ module EffectfulTranslation = struct let open Pp in let qs = IT.sym_ sym_args in let msg_s = "Iterated predicate pointer must be array_shift(ptr, q_var):" in - match IT.term ptr_expr with + match IT.get_term ptr_expr with | ArrayShift { base = p; ct; index = x } when Terms.equal_annot SBT.equal x qs -> let here = Locations.other __FUNCTION__ in return (p, IT.cast_ (SBT.proj bt) (IT.sizeOf_ ct here) here) @@ -1442,7 +1443,9 @@ let rec make_lrt_generic env st = st ) | CN_cletExpr (loc, name, expr) :: ensures -> let@ expr = handle st (ET.translate_cn_expr Sym.Set.empty env expr) in - let@ lrt, env, st = make_lrt_generic (add_logical name (IT.bt expr) env) st ensures in + let@ lrt, env, st = + make_lrt_generic (add_logical name (IT.get_bt expr) env) st ensures + in return (LRT.mDefine (name, IT.Surface.proj expr, (loc, None)) lrt, env, st) | CN_cconstr (loc, constr) :: ensures -> let@ lc = handle st (ET.translate_cn_assrt env (loc, constr)) in @@ -1513,7 +1516,7 @@ let translate_cn_lemma env (def : cn_lemma) = module UsingLoads = struct let pointee_ct loc it = - match IT.bt it with + match IT.get_bt it with | BT.Loc (Some ct) -> return ct | BT.Loc None -> let msg = !^"Cannot tell pointee C-type of" ^^^ squotes (IT.pp it) ^^ dot in diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index 5f6256f4c..247a3276e 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -16,7 +16,7 @@ type basetype_or_value = | BaseType of BT.t | Value of IndexTerms.t -let bt_of = function BaseType bt -> bt | Value v -> IndexTerms.bt v +let bt_of = function BaseType bt -> bt | Value v -> IndexTerms.get_bt v let has_value = function BaseType _ -> false | Value _ -> true diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index c2159cac3..846554ddf 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -896,7 +896,7 @@ let make_largs f_i = let@ expr = C.LocalState.handle st (C.ET.translate_cn_expr Sym.Set.empty env expr) in - let@ lat = aux (C.add_logical name (IT.bt expr) env) st conditions in + let@ lat = aux (C.add_logical name (IT.get_bt expr) env) st conditions in return (Mu.mDefine ((name, IT.Surface.proj expr), (loc, None)) lat) | Cn.CN_cconstr (loc, constr) :: conditions -> let@ lc = C.LocalState.handle st (C.ET.translate_cn_assrt env (loc, constr)) in diff --git a/backend/cn/lib/diagnostics.ml b/backend/cn/lib/diagnostics.ml index d96ce892c..f1b3ee3de 100644 --- a/backend/cn/lib/diagnostics.ml +++ b/backend/cn/lib/diagnostics.ml @@ -66,13 +66,13 @@ let term_with_model_name nm cfg x = let bool_subterms1 t = - match IT.term t with + match IT.get_term t with | IT.Binop (And, it, it') -> [ it; it' ] | IT.Binop (Or, it, it') -> [ it; it' ] | IT.Binop (Implies, x, y) -> [ x; y ] | IT.Unop (Not, x) -> [ x ] | IT.Binop (EQ, x, y) -> - if BT.equal (IT.bt x) BT.Bool then + if BT.equal (IT.get_bt x) BT.Bool then [ x; y ] else [] @@ -92,13 +92,13 @@ let constraint_ts () = let same_pred nm t = - match IT.term t with IT.Apply (nm2, _) -> Sym.equal nm nm2 | _ -> false + match IT.get_term t with IT.Apply (nm2, _) -> Sym.equal nm nm2 | _ -> false -let pred_args t = match IT.term t with IT.Apply (_, args) -> args | _ -> [] +let pred_args t = match IT.get_term t with IT.Apply (_, args) -> args | _ -> [] let split_eq x y = - match (IT.term x, IT.term y) with + match (IT.get_term x, IT.get_term y) with | IT.MapGet (m1, x1), IT.MapGet (m2, x2) -> Some [ (m1, m2); (x1, x2) ] | IT.Apply (nm, xs), IT.Apply (nm2, ys) when Sym.equal nm nm2 -> Some (List.map2 (fun x y -> (x, y)) xs ys) @@ -146,7 +146,7 @@ let rec investigate_term cfg t = return (List.concat trans_opts @ [ get_eq_opt ] @ split_opts) in let@ pred_opts = - match IT.term t with + match IT.get_term t with | IT.Apply (nm, _xs) -> investigate_pred cfg nm t | _ -> return [] in @@ -207,7 +207,8 @@ and investigate_trans_eq t cfg = (fun _ acc t -> match IT.is_eq t with | None -> acc - | Some (x, y) -> if BT.equal (IT.bt x) (IT.bt t) then [ x; y ] @ acc else acc) + | Some (x, y) -> + if BT.equal (IT.get_bt x) (IT.get_bt t) then [ x; y ] @ acc else acc) [] [] cs @@ -236,7 +237,7 @@ and get_eqs_then_investigate cfg x y = let x_set = IT.fold_list (fun _ acc t -> - if BT.equal (IT.bt t) (IT.bt x) then + if BT.equal (IT.get_bt t) (IT.get_bt x) then ITSet.add t acc else acc) @@ -279,7 +280,7 @@ and investigate_pred cfg nm t = and investigate_ite cfg t = let ites = IT.fold - (fun _ acc t -> match IT.term t with ITE (x, _y, _z) -> x :: acc | _ -> acc) + (fun _ acc t -> match IT.get_term t with ITE (x, _y, _z) -> x :: acc | _ -> acc) [] [] t diff --git a/backend/cn/lib/eqTable.ml b/backend/cn/lib/eqTable.ml index e2d0867d2..b5ded9acc 100644 --- a/backend/cn/lib/eqTable.ml +++ b/backend/cn/lib/eqTable.ml @@ -44,7 +44,7 @@ let add_eq_sym (guard, lhs, rhs) tab = let add_one_eq (tab : table) (it : IT.t) = - match IT.term it with + match IT.get_term it with | IT.Binop (IT.EQ, x, y) -> add_eq_sym (None, x, y) tab | Binop (Implies, guard, x) -> (match IT.is_eq x with Some (y, z) -> add_eq_sym (Some guard, y, z) tab | _ -> tab) diff --git a/backend/cn/lib/executable_spec_records.ml b/backend/cn/lib/executable_spec_records.ml index 1eb25410a..bac5becf4 100644 --- a/backend/cn/lib/executable_spec_records.ml +++ b/backend/cn/lib/executable_spec_records.ml @@ -9,7 +9,7 @@ module LAT = LogicalArgumentTypes module AT = ArgumentTypes let rec add_records_to_map_from_it it = - match IT.term it with + match IT.get_term it with | IT.Sym _s -> () | Const _c -> () | Unop (_uop, t1) -> add_records_to_map_from_it t1 @@ -24,7 +24,7 @@ let rec add_records_to_map_from_it it = | StructUpdate ((t1, _member), t2) -> List.iter add_records_to_map_from_it [ t1; t2 ] | Record members -> (* Anonymous record instantiation -> add to records map *) - Cn_internal_to_ail.augment_record_map (IT.bt it); + Cn_internal_to_ail.augment_record_map (IT.get_bt it); List.iter (fun (_, it') -> add_records_to_map_from_it it') members | RecordMember (t, _member) -> add_records_to_map_from_it t | RecordUpdate ((t1, _member), t2) -> List.iter add_records_to_map_from_it [ t1; t2 ] diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index e0990d322..f6471be02 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -267,7 +267,7 @@ let state ctxt log model_with_q extras = let interesting, uninteresting = List.partition (fun (it, _entry) -> - match IT.bt it with BT.Unit -> false | BT.Loc () -> false | _ -> true) + match IT.get_bt it with BT.Unit -> false | BT.Loc () -> false | _ -> true) filtered in add_labeled diff --git a/backend/cn/lib/indexTerms.ml b/backend/cn/lib/indexTerms.ml index 458e8d3ef..6e78f8710 100644 --- a/backend/cn/lib/indexTerms.ml +++ b/backend/cn/lib/indexTerms.ml @@ -24,18 +24,15 @@ end let basetype : 'a. 'a annot -> 'a = function IT (_, bt, _) -> bt -(* TODO rename this get_bt *) -let bt = basetype +let get_bt = basetype -(* TODO rename this get_term *) -let term (IT (t, _, _)) = t +let get_term (IT (t, _, _)) = t -(* TODO rename this get_loc *) -let loc (IT (_, _, l)) = l +let get_loc (IT (_, _, l)) = l let pp ?(prec = 0) = Terms.pp ~prec -let pp_with_typf f it = Pp.typ (pp it) (f (bt it)) +let pp_with_typf f it = Pp.typ (pp it) (f (get_bt it)) let pp_with_typ = pp_with_typf BT.pp @@ -62,9 +59,9 @@ let rec bound_by_pattern (Pat (pat_, bt, _)) = let rec free_vars_bts (it : 'a annot) : BT.t Sym.Map.t = - match term it with + match get_term it with | Const _ -> Sym.Map.empty - | Sym s -> Sym.Map.singleton s (bt it) + | Sym s -> Sym.Map.singleton s (get_bt it) | Unop (_uop, t1) -> free_vars_bts t1 | Binop (_bop, t1, t2) -> free_vars_bts_list [ t1; t2 ] | ITE (t1, t2, t3) -> free_vars_bts_list [ t1; t2; t3 ] @@ -397,7 +394,7 @@ let is_z = function IT (Const (Z z), _bt, _loc) -> Some z | _ -> None let is_z_ it = Option.is_some (is_z it) let get_num_z it = - match term it with + match get_term it with | Const (Z _) -> is_z it | Const (Bits (info, z)) -> Some (BT.normalise_to_range info z) | _ -> None @@ -512,7 +509,7 @@ let const_ctype_ ct loc = IT (Const (CType_const ct), BT.CType, loc) (* cmp_op *) let lt_ (it, it') loc = - if BT.equal (bt it) (bt it') then + if BT.equal (get_bt it) (get_bt it') then () else failwith ("lt_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])); @@ -520,7 +517,7 @@ let lt_ (it, it') loc = let le_ (it, it') loc = - if BT.equal (bt it) (bt it') then + if BT.equal (get_bt it) (get_bt it') then () else failwith ("le_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])); @@ -547,14 +544,14 @@ let or_ its loc = vargs_binop (bool_ false loc) (Tools.curry (fun p -> or2_ p lo let impl_ (it, it') loc = IT (Binop (Implies, it, it'), BT.Bool, loc) -let not_ it loc = IT (Unop (Not, it), bt it, loc) +let not_ it loc = IT (Unop (Not, it), get_bt it, loc) -let bw_compl_ it loc = IT (Unop (BW_Compl, it), bt it, loc) +let bw_compl_ it loc = IT (Unop (BW_Compl, it), get_bt it, loc) -let ite_ (it, it', it'') loc = IT (ITE (it, it', it''), bt it', loc) +let ite_ (it, it', it'') loc = IT (ITE (it, it', it''), get_bt it', loc) let eq_ (it, it') loc = - if BT.equal (bt it) (bt it') then + if BT.equal (get_bt it) (get_bt it') then () else failwith ("eq_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])); @@ -596,55 +593,55 @@ let eachI_ (i1, (s, bt), i2) t loc = IT (EachI ((i1, (s, bt), i2), t), BT.Bool, (* let existsI_ (i1, s, i2) t = not_ (eachI_ (i1, s, i2) (not_ t)) *) (* arith_op *) -let negate it loc = IT (Unop (Negate, it), bt it, loc) +let negate it loc = IT (Unop (Negate, it), get_bt it, loc) -let add_ (it, it') loc = IT (Binop (Add, it, it'), bt it, loc) +let add_ (it, it') loc = IT (Binop (Add, it, it'), get_bt it, loc) -let sub_ (it, it') loc = IT (Binop (Sub, it, it'), bt it, loc) +let sub_ (it, it') loc = IT (Binop (Sub, it, it'), get_bt it, loc) let mul_ (it, it') loc = - if BT.equal (bt it) (bt it') then - IT (Binop (Mul, it, it'), bt it, loc) + if BT.equal (get_bt it) (get_bt it') then + IT (Binop (Mul, it, it'), get_bt it, loc) else failwith ("mul_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])) -let mul_no_smt_ (it, it') loc = IT (Binop (MulNoSMT, it, it'), bt it, loc) +let mul_no_smt_ (it, it') loc = IT (Binop (MulNoSMT, it, it'), get_bt it, loc) -let div_ (it, it') loc = IT (Binop (Div, it, it'), bt it, loc) +let div_ (it, it') loc = IT (Binop (Div, it, it'), get_bt it, loc) -let div_no_smt_ (it, it') loc = IT (Binop (DivNoSMT, it, it'), bt it, loc) +let div_no_smt_ (it, it') loc = IT (Binop (DivNoSMT, it, it'), get_bt it, loc) -let exp_ (it, it') loc = IT (Binop (Exp, it, it'), bt it, loc) +let exp_ (it, it') loc = IT (Binop (Exp, it, it'), get_bt it, loc) -let exp_no_smt_ (it, it') loc = IT (Binop (ExpNoSMT, it, it'), bt it, loc) +let exp_no_smt_ (it, it') loc = IT (Binop (ExpNoSMT, it, it'), get_bt it, loc) -let rem_ (it, it') loc = IT (Binop (Rem, it, it'), bt it, loc) +let rem_ (it, it') loc = IT (Binop (Rem, it, it'), get_bt it, loc) -let rem_no_smt_ (it, it') loc = IT (Binop (RemNoSMT, it, it'), bt it, loc) +let rem_no_smt_ (it, it') loc = IT (Binop (RemNoSMT, it, it'), get_bt it, loc) -let mod_ (it, it') loc = IT (Binop (Mod, it, it'), bt it, loc) +let mod_ (it, it') loc = IT (Binop (Mod, it, it'), get_bt it, loc) -let mod_no_smt_ (it, it') loc = IT (Binop (ModNoSMT, it, it'), bt it, loc) +let mod_no_smt_ (it, it') loc = IT (Binop (ModNoSMT, it, it'), get_bt it, loc) -let divisible_ (it, it') loc = eq_ (mod_ (it, it') loc, int_lit_ 0 (bt it) loc) loc +let divisible_ (it, it') loc = eq_ (mod_ (it, it') loc, int_lit_ 0 (get_bt it) loc) loc let rem_f_ (it, it') loc = mod_ (it, it') loc -let min_ (it, it') loc = IT (Binop (Min, it, it'), bt it, loc) +let min_ (it, it') loc = IT (Binop (Min, it, it'), get_bt it, loc) -let max_ (it, it') loc = IT (Binop (Max, it, it'), bt it, loc) +let max_ (it, it') loc = IT (Binop (Max, it, it'), get_bt it, loc) let intToReal_ it loc = IT (Cast (Real, it), BT.Real, loc) let realToInt_ it loc = IT (Cast (Integer, it), BT.Integer, loc) -let arith_binop op (it, it') loc = IT (Binop (op, it, it'), bt it, loc) +let arith_binop op (it, it') loc = IT (Binop (op, it, it'), get_bt it, loc) -let arith_unop op it loc = IT (Unop (op, it), bt it, loc) +let arith_unop op it loc = IT (Unop (op, it), get_bt it, loc) let arith_binop_check op (it, it') loc = - assert (BT.equal (bt it) (bt it')); + assert (BT.equal (get_bt it) (get_bt it')); arith_binop op (it, it') loc @@ -671,7 +668,7 @@ let ( %> ) t t' = gt_ (t, t') let ( %>= ) t t' = ge_ (t, t') (* tuple_op *) -let tuple_ its loc = IT (Tuple its, BT.Tuple (List.map bt its), loc) +let tuple_ its loc = IT (Tuple its, BT.Tuple (List.map get_bt its), loc) let nthTuple_ ~item_bt (n, it) loc = IT (NthTuple (n, it), item_bt, loc) @@ -682,7 +679,7 @@ let member_ ~member_bt (it, member) loc = IT (StructMember (it, member), member_ let ( %. ) struct_decls t member = let tag = - match bt t with + match get_bt t with | BT.Struct tag -> tag | _ -> Cerb_debug.error "illtyped index term. not a struct" in @@ -717,7 +714,9 @@ let gtPointer_ (it, it') loc = ltPointer_ (it', it) loc let gePointer_ (it, it') loc = lePointer_ (it', it) loc -let cast_ bt' it loc = if BT.equal bt' (bt it) then it else IT (Cast (bt', it), bt', loc) +let cast_ bt' it loc = + if BT.equal bt' (get_bt it) then it else IT (Cast (bt', it), bt', loc) + let uintptr_const_ n loc = num_lit_ n Memory.uintptr_bt loc @@ -725,7 +724,7 @@ let uintptr_int_ n loc = uintptr_const_ (Z.of_int n) loc (* for integer-mode: z_ n *) let addr_ it loc = - assert (BT.equal (bt it) (Loc ())); + assert (BT.equal (get_bt it) (Loc ())); cast_ Memory.uintptr_bt it loc @@ -775,26 +774,26 @@ let pointer_offset_ (base, offset) loc = (* list_op *) let nil_ ~item_bt loc = IT (Nil item_bt, BT.List item_bt, loc) -let cons_ (it, it') loc = IT (Cons (it, it'), bt it', loc) +let cons_ (it, it') loc = IT (Cons (it, it'), get_bt it', loc) let list_ ~item_bt its ~nil_loc = let rec aux = function | [] -> IT (Nil item_bt, BT.List item_bt, nil_loc) - | x :: xs -> IT (Cons (x, aux xs), BT.List item_bt, loc x) + | x :: xs -> IT (Cons (x, aux xs), BT.List item_bt, get_loc x) in aux its let head_ ~item_bt it loc = IT (Head it, item_bt, loc) -let tail_ it loc = IT (Tail it, bt it, loc) +let tail_ it loc = IT (Tail it, get_bt it, loc) -let nthList_ (n, it, d) loc = IT (NthList (n, it, d), bt d, loc) +let nthList_ (n, it, d) loc = IT (NthList (n, it, d), get_bt d, loc) let array_to_list_ (arr, i, len) bt loc = IT (ArrayToList (arr, i, len), bt, loc) let rec dest_list it = - match term it with + match get_term it with | Nil _bt -> Some [] | Cons (x, xs) -> Option.map (fun ys -> x :: ys) (dest_list xs) (* TODO: maybe include Tail, if we ever actually use it? *) @@ -806,7 +805,7 @@ let setMember_ (it, it') loc = IT (Binop (SetMember, it, it'), BT.Bool, loc) (* let setUnion_ its = IT (Set_op (SetUnion its), bt (hd its)) * let setIntersection_ its = IT (Set_op (SetIntersection its), bt (hd its)) *) -let setDifference_ (it, it') loc = IT (Binop (SetDifference, it, it'), bt it, loc) +let setDifference_ (it, it') loc = IT (Binop (SetDifference, it, it'), get_bt it, loc) let subset_ (it, it') loc = IT (Binop (Subset, it, it'), BT.Bool, loc) @@ -820,8 +819,8 @@ let wrapI_ (ity, arg) loc = let alignedI_ ~t ~align loc = - assert (BT.equal (bt t) (Loc ())); - assert (BT.equal Memory.uintptr_bt (bt align)); + assert (BT.equal (get_bt t) (Loc ())); + assert (BT.equal Memory.uintptr_bt (get_bt align)); IT (Aligned { t; align }, BT.Bool, loc) @@ -829,14 +828,16 @@ let aligned_ (t, ct) loc = alignedI_ ~t ~align:(int_lit_ (Memory.align_of_ctype ct) Memory.uintptr_bt loc) loc -let const_map_ index_bt t loc = IT (MapConst (index_bt, t), BT.Map (index_bt, bt t), loc) +let const_map_ index_bt t loc = + IT (MapConst (index_bt, t), BT.Map (index_bt, get_bt t), loc) + -let map_set_ t1 (t2, t3) loc = IT (MapSet (t1, t2, t3), bt t1, loc) +let map_set_ t1 (t2, t3) loc = IT (MapSet (t1, t2, t3), get_bt t1, loc) let map_get_ v arg loc = - match bt v with + match get_bt v with | BT.Map (dt, rbt) -> - if BT.equal dt (bt arg) then + if BT.equal dt (get_bt arg) then () else failwith ("mag_get_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ v; arg ])); @@ -844,7 +845,9 @@ let map_get_ v arg loc = | _ -> Cerb_debug.error "illtyped index term" -let map_def_ (s, abt) body loc = IT (MapDef ((s, abt), body), BT.Map (abt, bt body), loc) +let map_def_ (s, abt) body loc = + IT (MapDef ((s, abt), body), BT.Map (abt, get_bt body), loc) + let make_array_ ~index_bt ~item_bt items (* assumed all of item_bt *) loc = let base_value = const_map_ index_bt (default_ item_bt loc) loc in @@ -879,17 +882,17 @@ let fresh_same bt symbol' loc = (symbol, sym_ (symbol, bt, loc)) -let def_ sym e loc = eq_ (sym_ (sym, bt e, loc), e) loc +let def_ sym e loc = eq_ (sym_ (sym, get_bt e, loc), e) loc let in_range within (min, max) loc = and_ [ le_ (min, within) loc; le_ (within, max) loc ] loc let rec in_z_range within (min_z, max_z) loc = - match bt within with + match get_bt within with | BT.Integer -> in_range within (z_ min_z loc, z_ max_z loc) loc | BT.Bits (sign, sz) -> - let the_bt = bt within in + let the_bt = get_bt within in let min_possible, max_possible = BT.bits_range (sign, sz) in let min_c = if Z.leq min_z min_possible then @@ -989,7 +992,7 @@ let value_check mode (struct_layouts : Memory.struct_decls) ct about loc = (); (* let partiality = partiality_check_array ~length:n ~item_ct about in *) let ix_bt = - match BT.is_map_bt (bt about) with + match BT.is_map_bt (get_bt about) with | Some (abt, _) -> abt | _ -> failwith ("value_check: argument not a map: " ^ Pp.plain (pp_with_typ about)) @@ -1030,7 +1033,7 @@ let good_pointer = value_check_pointer `Good let promote_to_compare it it' loc = let res_bt = - match (bt it, bt it') with + match (get_bt it, get_bt it') with | bt1, bt2 when BT.equal bt1 bt2 -> bt1 | BT.Bits (_, sz), BT.Bits (_, sz') -> BT.Bits (BT.Signed, sz + sz' + 2) | _ -> @@ -1038,20 +1041,20 @@ let promote_to_compare it it' loc = ("promote to compare: impossible types to compare: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])) in - let cast it = if BT.equal (bt it) res_bt then it else cast_ res_bt it loc in + let cast it = if BT.equal (get_bt it) res_bt then it else cast_ res_bt it loc in (cast it, cast it') let nth_array_to_list_fact n xs d = let here = Locations.other __FUNCTION__ in - match term xs with + match get_term xs with | ArrayToList (arr, i, len) -> let lt_n_len = lt_ (promote_to_compare n len here) here in let lhs = nthList_ (n, xs, d) here in let rhs = ite_ - ( and_ [ le_ (int_lit_ 0 (bt n) here, n) here; lt_n_len ] here, - map_get_ arr (add_ (i, cast_ (bt i) n here) here) here, + ( and_ [ le_ (int_lit_ 0 (get_bt n) here, n) here; lt_n_len ] here, + map_get_ arr (add_ (i, cast_ (get_bt i) n here) here) here, d ) here in @@ -1089,13 +1092,15 @@ let nth_array_to_list_facts (binders_terms : (t_bindings * t) list) = let nths = List.filter_map (fun (bs, it) -> - match term it with NthList (n, xs, d) -> Some (bs, (n, d, bt xs)) | _ -> None) + match get_term it with + | NthList (n, xs, d) -> Some (bs, (n, d, get_bt xs)) + | _ -> None) binders_terms in let arr_lists = List.filter_map (fun (bs, it) -> - match term it with ArrayToList _ -> Some (bs, (it, bt it)) | _ -> None) + match get_term it with ArrayToList _ -> Some (bs, (it, get_bt it)) | _ -> None) binders_terms in List.concat_map @@ -1252,7 +1257,7 @@ module Bounds = struct ^^^ !^"in permission" ^^^ squotes (pp it) ^^^ !^"at" - ^^^ Locations.pp (loc it)))) + ^^^ Locations.pp (get_loc it)))) (); exit 2 in @@ -1304,7 +1309,7 @@ module Bounds = struct ^^^ !^"in permission" ^^^ squotes (pp it) ^^^ !^"at" - ^^^ Locations.pp (loc it)))) + ^^^ Locations.pp (get_loc it)))) (); exit 2 in diff --git a/backend/cn/lib/interval.ml b/backend/cn/lib/interval.ml index 9f39ebd72..26ba989c7 100644 --- a/backend/cn/lib/interval.ml +++ b/backend/cn/lib/interval.ml @@ -189,13 +189,13 @@ module Solver = struct open BaseTypes let interval_for (eval : IT.t -> IT.t option) q tyi = - let is_q i = match IT.term i with Sym y -> Sym.equal q y | _ -> false in + let is_q i = match IT.get_term i with Sym y -> Sym.equal q y | _ -> false in let eval_k e = if Sym.Set.mem q (IT.free_vars e) then None else Option.bind (eval e) (fun v -> - match IT.term v with + match IT.get_term v with | Const (Z z) -> Some z | Const (Bits (_, z)) -> Some z | _ -> None) @@ -214,7 +214,7 @@ module Solver = struct let do_compl i = mkI (Intervals.complement i) in let do_impl i j = Intervals.union (do_compl i) j in let rec interval p = - match IT.term p with + match IT.get_term p with | Const (Bool true) -> Some tyi | Const (Bool false) -> Some (Intervals.of_interval Interval.empty) | Unop (Not, term) -> Option.map do_compl (interval term) @@ -249,7 +249,7 @@ module Solver = struct | RT.P _ -> rt | RT.Q qpred -> let x, t = qpred.q in - let loc = IT.loc qpred.permission in + let loc = IT.get_loc qpred.permission in (match supported_type loc t with | None -> rt | Some (tyi, k) -> diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index e648918ba..8d18d8ce1 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -380,8 +380,8 @@ let alpha_rename_if_pp_same s body = let it_adjust (global : Global.t) it = let rec f t = - let loc = IT.loc t in - match IT.term t with + let loc = IT.get_loc t in + match IT.get_term t with | IT.Binop (And, x1, x2) -> let xs = List.map f [ x1; x2 ] |> List.partition IT.is_true |> snd in IT.and_ xs loc @@ -929,7 +929,7 @@ let it_to_coq loc global list_mono it = let abinop s x y = parensM (build [ aux x; rets s; aux y ]) in let enc_prop = Option.is_none comp_bool in let with_is_true x = - if enc_prop && BaseTypes.equal (IT.bt t) BaseTypes.Bool then + if enc_prop && BaseTypes.equal (IT.get_bt t) BaseTypes.Bool then f_appM "Is_true" [ x ] else x @@ -949,7 +949,7 @@ let it_to_coq loc global list_mono it = *) f in - match IT.term t with + match IT.get_term t with | IT.Sym sym -> return (Sym.pp sym) | IT.Const l -> (match l with @@ -959,7 +959,7 @@ let it_to_coq loc global list_mono it = | _ -> do_fail "const") | IT.Unop (op, x) -> norm_bv_op - (IT.bt t) + (IT.get_bt t) (match op with | IT.Not -> f_appM (if enc_prop then "~" else "negb") [ aux x ] | IT.BW_FFS_NoSMT -> f_appM "CN_Lib.find_first_set_z" [ aux x ] @@ -967,7 +967,7 @@ let it_to_coq loc global list_mono it = | _ -> do_fail "unary op") | IT.Binop (op, x, y) -> norm_bv_op - (IT.bt t) + (IT.get_bt t) (match op with | Add -> abinop "+" x y | Sub -> abinop "-" x y @@ -1027,11 +1027,11 @@ let it_to_coq loc global list_mono it = return (parens enc) | IT.MapSet (m, x, y) -> let@ () = ensure_fun_upd () in - let@ e = eq_of (IT.bt x) in + let@ e = eq_of (IT.get_bt x) in f_appM "fun_upd" [ return e; aux m; aux x; aux y ] | IT.MapGet (m, x) -> parensM (build [ aux m; aux x ]) | IT.RecordMember (t, m) -> - let flds = BT.record_bt (IT.bt t) in + let flds = BT.record_bt (IT.get_bt t) in if List.length flds == 1 then aux t else ( @@ -1039,7 +1039,7 @@ let it_to_coq loc global list_mono it = let@ op_nm = ensure_tuple_op false (Id.pp_string m) ix in parensM (build [ rets op_nm; aux t ])) | IT.RecordUpdate ((t, m), x) -> - let flds = BT.record_bt (IT.bt t) in + let flds = BT.record_bt (IT.get_bt t) in if List.length flds == 1 then aux x else ( @@ -1050,7 +1050,7 @@ let it_to_coq loc global list_mono it = let@ xs = ListM.mapM aux (List.map snd mems) in parensM (return (flow (comma ^^ break 1) xs)) | IT.StructMember (t, m) -> - let tag = BaseTypes.struct_bt (IT.bt t) in + let tag = BaseTypes.struct_bt (IT.get_bt t) in let mems, _bts = get_struct_xs global.struct_decls tag in let ix = find_tuple_element Id.equal m Id.pp mems in if List.length mems == 1 then @@ -1059,7 +1059,7 @@ let it_to_coq loc global list_mono it = let@ op_nm = ensure_tuple_op false (Id.pp_string m) ix in parensM (build [ rets op_nm; aux t ]) | IT.StructUpdate ((t, m), x) -> - let tag = BaseTypes.struct_bt (IT.bt t) in + let tag = BaseTypes.struct_bt (IT.get_bt t) in let mems, _bts = get_struct_xs global.struct_decls tag in let ix = find_tuple_element Id.equal m Id.pp mems in if List.length mems == 1 then @@ -1068,7 +1068,7 @@ let it_to_coq loc global list_mono it = let@ op_nm = ensure_tuple_op true (Id.pp_string m) ix in parensM (build [ rets op_nm; aux t; aux x ]) | IT.Cast (cbt, t) -> - (match (IT.bt t, cbt) with + (match (IT.get_bt t, cbt) with | Integer, Loc () -> aux t | Loc (), Integer -> aux t | source, target -> @@ -1097,10 +1097,10 @@ let it_to_coq loc global list_mono it = (* assuming here that the id's are in canonical order *) parensM (build ([ return (Sym.pp nm) ] @ List.map (f comp) (List.map snd id_args))) | IT.NthList (n, xs, d) -> - let@ _, _, dest = ensure_list global list_mono loc (IT.bt xs) in + let@ _, _, dest = ensure_list global list_mono loc (IT.get_bt xs) in parensM (build [ rets "CN_Lib.nth_list_z"; return dest; aux n; aux xs; aux d ]) | IT.ArrayToList (arr, i, len) -> - let@ nil, cons, _ = ensure_list global list_mono loc (IT.bt t) in + let@ nil, cons, _ = ensure_list global list_mono loc (IT.get_bt t) in parensM (build [ rets "CN_Lib.array_to_list"; diff --git a/backend/cn/lib/logicalArgumentTypes.ml b/backend/cn/lib/logicalArgumentTypes.ml index 1abcdf76c..9282f1a36 100644 --- a/backend/cn/lib/logicalArgumentTypes.ml +++ b/backend/cn/lib/logicalArgumentTypes.ml @@ -167,7 +167,7 @@ let binders i_binders i_subst = let rec aux = function | Define ((s, it), _, t) -> let s, t = alpha_rename i_subst s t in - (Id.id (Sym.pp_string s), IT.bt it) :: aux t + (Id.id (Sym.pp_string s), IT.get_bt it) :: aux t | Resource ((s, (_, bt)), _, t) -> let s, t = alpha_rename i_subst s t in (Id.id (Sym.pp_string s), bt) :: aux t diff --git a/backend/cn/lib/logicalReturnTypes.ml b/backend/cn/lib/logicalReturnTypes.ml index 3b5659b7d..53a334e4d 100644 --- a/backend/cn/lib/logicalReturnTypes.ml +++ b/backend/cn/lib/logicalReturnTypes.ml @@ -87,7 +87,7 @@ let binders = let rec aux = function | Define ((s, it), _, t) -> let s, t = alpha_rename s t in - (Id.id (Sym.pp_string s), IT.bt it) :: aux t + (Id.id (Sym.pp_string s), IT.get_bt it) :: aux t | Resource ((s, (_, bt)), _, t) -> let s, t = alpha_rename s t in (Id.id (Sym.pp_string s), bt) :: aux t diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index aeeb9da63..2274ef238 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -47,7 +47,7 @@ let packing_ft loc global provable ret = | Owned ((Array (ict, olength) as ct), init) -> let qpred = unfolded_array loc init (ict, olength) ret.pointer in let o_s, o = IT.fresh_named (Memory.bt_of_sct ct) "value" loc in - let at = LAT.Resource ((o_s, (qpred, IT.bt o)), (loc, None), LAT.I o) in + let at = LAT.Resource ((o_s, (qpred, IT.get_bt o)), (loc, None), LAT.I o) in Some at | Owned (Struct tag, init) -> let layout = Sym.Map.find tag global.Global.struct_decls in @@ -66,7 +66,7 @@ let packing_ft loc global provable ret = let m_value_s, m_value = IT.fresh_named (Memory.bt_of_sct mct) (Id.s member) loc in - ( LRT.Resource ((m_value_s, (request, IT.bt m_value)), (loc, None), lrt), + ( LRT.Resource ((m_value_s, (request, IT.get_bt m_value)), (loc, None), lrt), (member, m_value) :: value ) | None -> let padding_ct = Sctypes.Array (Sctypes.char_ct, Some size) in @@ -81,7 +81,7 @@ let packing_ft loc global provable ret = let padding_s, padding = IT.fresh_named (Memory.bt_of_sct padding_ct) "padding" loc in - ( LRT.Resource ((padding_s, (request, IT.bt padding)), (loc, None), lrt), + ( LRT.Resource ((padding_s, (request, IT.get_bt padding)), (loc, None), lrt), value )) layout (LRT.I, []) @@ -155,8 +155,8 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O (* in *) match ret with | Q ret - when Request.equal_name predicate_name ret.name && BT.equal (IT.bt index) (snd ret.q) - -> + when Request.equal_name predicate_name ret.name + && BT.equal (IT.get_bt index) (snd ret.q) -> let su = IT.make_subst [ (fst ret.q, index) ] in let index_permission = IT.subst su ret.permission in (match prove_or_model (LC.T index_permission) with @@ -199,11 +199,11 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O (* then () *) (* (\* tmsg "not extracting, predicate name differs" *\) *) (* (\* (lazy (Request.pp_predicate_name predicate_name)) *\) *) - (* else if not (BT.equal (IT.bt index) (snd qret.q)) *) + (* else if not (BT.equal (IT.get_bt index) (snd qret.q)) *) (* then *) (* () *) (* (\* tmsg "not extracting, index type differs" *\) *) - (* (\* (lazy (Pp.typ (BT.pp (IT.bt index)) (BT.pp (snd qret.q)))) *\) *) + (* (\* (lazy (Pp.typ (BT.pp (IT.get_bt index)) (BT.pp (snd qret.q)))) *\) *) (* else assert false; *) (* None *) | _ -> None diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 78954fce6..81966b0ff 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -331,7 +331,7 @@ module General = struct if (not (IT.is_false needed)) && Req.subsumed requested.name predicate_name - && BaseTypes.equal (snd requested.q) (IT.bt index) + && BaseTypes.equal (snd requested.q) (IT.get_bt index) then ( let su = IT.make_subst [ (fst requested.q, index) ] in let needed_at_index = IT.subst su needed in diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index 432f55f7d..cef51b9b0 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -41,8 +41,8 @@ module IndexTerms = struct let z0 = z_ Z.zero (Cerb_location.other __FUNCTION__) let rec dest_int_addition ts it = - let loc = IT.loc it in - match IT.term it with + let loc = IT.get_loc it in + match IT.get_term it with | Const (Z i1) -> if fst ts || ITSet.mem z1 (snd ts) then ([ (z1, i1) ], z0) else ([], it) | Binop (Add, a, b) -> @@ -129,8 +129,8 @@ module IndexTerms = struct let rec record_member_reduce it member = - let loc = IT.loc it in - match IT.term it with + let loc = IT.get_loc it in + match IT.get_term it with | Record members -> List.assoc Id.equal member members | RecordUpdate ((t, m), v) -> if Id.equal m member then @@ -140,15 +140,15 @@ module IndexTerms = struct | ITE (cond, it1, it2) -> ite_ (cond, record_member_reduce it1 member, record_member_reduce it2 member) loc | _ -> - let member_tys = BT.record_bt (IT.bt it) in + let member_tys = BT.record_bt (IT.get_bt it) in let member_bt = List.assoc Id.equal member member_tys in IT.recordMember_ ~member_bt (it, member) loc (* let rec datatype_member_reduce it member member_bt = *) - (* match IT.term it with *) + (* match IT.get_term it with *) (* | DatatypeCons (nm, members_rec) -> *) - (* let members = BT.record_bt (IT.bt members_rec) in *) + (* let members = BT.record_bt (IT.get_bt members_rec) in *) (* if List.exists (Id.equal member) (List.map fst members) *) (* then record_member_reduce members_rec member *) (* else IT.IT (DatatypeMember (it, member), member_bt) *) @@ -158,8 +158,8 @@ module IndexTerms = struct (* | _ -> IT.IT (DatatypeMember (it, member), member_bt) *) let rec tuple_nth_reduce it n item_bt = - let loc = IT.loc it in - match IT.term it with + let loc = IT.get_loc it in + match IT.get_term it with | Tuple items -> List.nth items n | ITE (cond, it1, it2) -> ite_ (cond, tuple_nth_reduce it1 n item_bt, tuple_nth_reduce it2 n item_bt) loc @@ -167,9 +167,9 @@ module IndexTerms = struct let rec accessor_reduce (f : IT.t -> IT.t option) it = - let bt = IT.bt it in + let bt = IT.get_bt it in let step, it2 = - match IT.term it with + match IT.get_term it with | RecordMember (t, m) -> (true, record_member_reduce (accessor_reduce f t) m) (* | DatatypeMember (t, m) -> *) (* (true, datatype_member_reduce (accessor_reduce f t) m bt) *) @@ -183,9 +183,9 @@ module IndexTerms = struct let cast_reduce bt it = - let loc = IT.loc it in + let loc = IT.get_loc it in match (bt, IT.is_const it) with - | _, _ when BT.equal (IT.bt it) bt -> it + | _, _ when BT.equal (IT.get_bt it) bt -> it | BT.Bits (sign, sz), Some (Terms.Bits ((sign2, sz2), z), _) -> let z = BT.normalise_to_range (sign, sz) (BT.normalise_to_range (sign2, sz2) z) in num_lit_ z bt loc @@ -376,7 +376,7 @@ module IndexTerms = struct | _ -> IT (Binop (Implies, a, b), the_bt, the_loc)) | Unop (op, a) -> let a = aux a in - (match (op, IT.term a) with + (match (op, IT.get_term a) with | Not, Const (Bool b) -> bool_ (not b) the_loc | Not, Unop (Not, x) -> x | Negate, Unop (Negate, x) -> x @@ -463,7 +463,7 @@ module IndexTerms = struct | Struct (tag, members) -> (match members with | (_, IT (StructMember (str, _), _, _)) :: _ - when BT.equal (Struct tag) (IT.bt str) + when BT.equal (Struct tag) (IT.get_bt str) && List.for_all (function | mem, IT (StructMember (str', mem'), _, _) -> @@ -568,7 +568,7 @@ module IndexTerms = struct let rec make map index = match map with | IT (MapDef ((s, abt), body), _, _) -> - assert (BT.equal abt (IT.bt index)); + assert (BT.equal abt (IT.get_bt index)); aux (IT.subst (IT.make_subst [ (s, index) ]) body) | IT (MapSet (map', index', value'), _, _) -> (match (index, index') with @@ -625,7 +625,7 @@ module LogicalConstraints = struct let q, body = IT.alpha_rename q body in let body = simp ~inline_functions simp_ctxt body in (match body with - | IT (Const (Bool true), _, _) -> LC.T (bool_ true (IT.loc body)) + | IT (Const (Bool true), _, _) -> LC.T (bool_ true (IT.get_loc body)) | _ -> LC.Forall ((q, qbt), body)) end @@ -652,7 +652,7 @@ module Request = struct q = qp.q; q_loc = qp.q_loc; step = IndexTerms.simp simp_ctxt qp.step; - permission = and_ permission (IT.loc qp.permission); + permission = and_ permission (IT.get_loc qp.permission); iargs = List.map (IndexTerms.simp simp_ctxt) qp.iargs } end diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 07070eca3..ff7b32591 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -691,7 +691,7 @@ let translate_var s name bt = (** Translate a CN term to SMT *) let rec translate_term s iterm = - let loc = IT.loc iterm in + let loc = IT.get_loc iterm in let struct_decls = s.globals.struct_decls in let maybe_name e k = if SMT.is_atom e then @@ -704,14 +704,14 @@ let rec translate_term s iterm = let here = Locations.other (__FUNCTION__ ^ string_of_int __LINE__) in translate_term s (IT.default_ bt here) in - match IT.term iterm with + match IT.get_term iterm with | Const c -> translate_const s c | Sym x -> translate_var s x (IT.basetype iterm) | Unop (op, e1) -> (match op with | BW_FFS_NoSMT -> (* NOTE: This desugaring duplicates e1 *) - let intl i = int_lit_ i (IT.bt e1) loc in + let intl i = int_lit_ i (IT.get_bt e1) loc in translate_term s (ite_ @@ -722,8 +722,8 @@ let rec translate_term s iterm = | BW_FLS_NoSMT -> (* copying and adjusting BW_FFS_NoSMT rule *) (* NOTE: This desugaring duplicates e1 *) - let sz = match IT.bt e1 with Bits (_sign, n) -> n | _ -> assert false in - let intl i = int_lit_ i (IT.bt e1) loc in + let sz = match IT.get_bt e1 with Bits (_sign, n) -> n | _ -> assert false in + let intl i = int_lit_ i (IT.get_bt e1) loc in translate_term s (ite_ @@ -789,7 +789,7 @@ let rec translate_term s iterm = | Exp -> (match (get_num_z e1, get_num_z e2) with | Some z1, Some z2 when Z.fits_int z2 -> - translate_term s (num_lit_ (Z.pow z1 (Z.to_int z2)) (IT.bt e1) loc) + translate_term s (num_lit_ (Z.pow z1 (Z.to_int z2)) (IT.get_bt e1) loc) | _, _ -> failwith "Exp") | ExpNoSMT -> uninterp_same_type CN_Constant.exp | Rem -> @@ -889,8 +889,8 @@ let rec translate_term s iterm = | StructMember (e1, f) -> SMT.app_ (CN_Names.struct_field_name f) [ translate_term s e1 ] | StructUpdate ((t, member), v) -> - let tag = BT.struct_bt (IT.bt t) in - let layout = Sym.Map.find (struct_bt (IT.bt t)) struct_decls in + let tag = BT.struct_bt (IT.get_bt t) in + let layout = Sym.Map.find (struct_bt (IT.get_bt t)) struct_decls in let members = Memory.member_types layout in let str = List.map @@ -923,7 +923,7 @@ let rec translate_term s iterm = | None -> failwith "Missing record field.") | _ -> failwith "RecordMemmber") | RecordUpdate ((t, member), v) -> - let members = BT.record_bt (IT.bt t) in + let members = BT.record_bt (IT.get_bt t) in let str = List.map (fun (member', bt) -> @@ -936,7 +936,7 @@ let rec translate_term s iterm = (member', value)) members in - translate_term s (IT (Record str, IT.bt t, loc)) + translate_term s (IT (Record str, IT.get_bt t, loc)) | MemberShift (t, tag, member) -> CN_Pointer.ptr_shift ~ptr:(translate_term s t) @@ -950,7 +950,7 @@ let rec translate_term s iterm = (let el_size = int_lit_ (Memory.size_of_ctype ct) Memory.uintptr_bt loc in (* locations don't matter here - we are translating straight away *) let ix = - if BT.equal (IT.bt index) Memory.uintptr_bt then + if BT.equal (IT.get_bt index) Memory.uintptr_bt then index else cast_ Memory.uintptr_bt index loc @@ -991,7 +991,7 @@ let rec translate_term s iterm = | Good (ct, t) -> translate_term s (good_value struct_decls ct t loc) | Aligned t -> let addr = addr_ t.t loc in - assert (BT.equal (IT.bt addr) (IT.bt t.align)); + assert (BT.equal (IT.get_bt addr) (IT.get_bt t.align)); translate_term s (divisible_ (addr, t.align) loc) (* Maps *) | MapConst (bt, e1) -> @@ -1055,17 +1055,17 @@ let rec translate_term s iterm = | WrapI (ity, arg) -> bv_cast ~to_:(Memory.bt_of_sct (Sctypes.Integer ity)) - ~from:(IT.bt arg) + ~from:(IT.get_bt arg) (translate_term s arg) | Cast (cbt, t) -> let smt_term = translate_term s t in - (match (IT.bt t, cbt) with + (match (IT.get_bt t, cbt) with | Bits _, Loc () -> let addr = - if BT.equal (IT.bt t) Memory.uintptr_bt then + if BT.equal (IT.get_bt t) Memory.uintptr_bt then smt_term else - bv_cast ~to_:Memory.uintptr_bt ~from:(IT.bt t) smt_term + bv_cast ~to_:Memory.uintptr_bt ~from:(IT.get_bt t) smt_term in CN_Pointer.bits_to_ptr ~bits:addr ~alloc_id:(default Alloc_id) | Loc (), Bits _ -> @@ -1089,7 +1089,7 @@ let rec translate_term s iterm = | MemByte, Alloc_id -> SMT.app_ CN_MemByte.alloc_id_name [ smt_term ] | Real, Integer -> SMT.real_to_int smt_term | Integer, Real -> SMT.int_to_real smt_term - | Bits _, Bits _ -> bv_cast ~to_:cbt ~from:(IT.bt t) smt_term + | Bits _, Bits _ -> bv_cast ~to_:cbt ~from:(IT.get_bt t) smt_term | _ -> assert false) diff --git a/backend/cn/lib/testGeneration/genBuiltins.ml b/backend/cn/lib/testGeneration/genBuiltins.ml index 5babfce49..16a1d6dac 100644 --- a/backend/cn/lib/testGeneration/genBuiltins.ml +++ b/backend/cn/lib/testGeneration/genBuiltins.ml @@ -31,13 +31,15 @@ let gen_syms_bits (name : string) : (BT.t * Sym.t) list = let mult_check (it_mult : IT.t) gt loc = - GT.assert_ (T (IT.gt_ (it_mult, IT.num_lit_ Z.zero (IT.bt it_mult) loc) loc), gt) loc + GT.assert_ + (T (IT.gt_ (it_mult, IT.num_lit_ Z.zero (IT.get_bt it_mult) loc) loc), gt) + loc let lt_check (it_max : IT.t) gt loc = - let sgn, sz = Option.get (BT.is_bits_bt (IT.bt it_max)) in + let sgn, sz = Option.get (BT.is_bits_bt (IT.get_bt it_max)) in let min, _ = BT.bits_range (sgn, sz) in - GT.assert_ (T (IT.gt_ (it_max, IT.num_lit_ min (IT.bt it_max) loc) loc), gt) loc + GT.assert_ (T (IT.gt_ (it_max, IT.num_lit_ min (IT.get_bt it_max) loc) loc), gt) loc let range_check (it_min : IT.t) (it_max : IT.t) gt loc = @@ -139,13 +141,13 @@ let aligned_alloc_gen_sym = Sym.fresh_named "cn_gen_aligned_alloc" let aligned_alloc_gen (it_align : IT.t) (it_size : IT.t) loc : GT.t = let it_align = - if BT.equal (IT.bt it_align) Memory.size_bt then + if BT.equal (IT.get_bt it_align) Memory.size_bt then it_align else IT.cast_ Memory.size_bt it_align loc in let it_size = - if BT.equal (IT.bt it_size) Memory.size_bt then + if BT.equal (IT.get_bt it_size) Memory.size_bt then it_size else IT.cast_ Memory.size_bt it_align loc diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index 549278d2d..cb4257083 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -230,7 +230,7 @@ let rec compile_term ~executable_spec:true C.no_qualifiers (Sctypes.to_ctype sct))))); - mk_expr (CtA.wrap_with_convert_from e2_ (IT.bt value)); + mk_expr (CtA.wrap_with_convert_from e2_ (IT.get_bt value)); mk_expr (AilEident (Sym.fresh ())); mk_expr (AilEcast diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index d6862e293..af9bc2932 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -113,7 +113,7 @@ let rec compile_it_lat match lat with | Define ((x, it), (loc, _), lat') -> let@ gt' = compile_it_lat filename recursive preds name generated oargs lat' in - return (GT.let_ (backtrack_num, (x, GT.return_ it (IT.loc it)), gt') loc) + return (GT.let_ (backtrack_num, (x, GT.return_ it (IT.get_loc it)), gt') loc) | Resource ((x, (P { name = Owned (ct, _); pointer; iargs = _ }, bt)), (loc, _), lat') -> let@ gt' = compile_it_lat filename recursive preds name generated oargs lat' in @@ -182,7 +182,7 @@ let rec compile_it_lat let gt_body = let sym_val = Sym.fresh () in let it_q = IT.sym_ (q_sym, k_bt, q_loc) in - let it_p = IT.add_ (pointer, IT.mul_ (it_q, step) (IT.loc step)) loc in + let it_p = IT.add_ (pointer, IT.mul_ (it_q, step) (IT.get_loc step)) loc in let gt_asgn = GT.asgn_ ( (it_p, ct), @@ -217,7 +217,7 @@ let rec compile_it_lat let pred = List.assoc Sym.equal fsym preds in let arg_syms = pred.pointer :: fst (List.split pred.iargs) in let it_q = IT.sym_ (q_sym, q_bt, q_loc) in - let it_p = IT.add_ (pointer, IT.mul_ (it_q, step) (IT.loc step)) loc in + let it_p = IT.add_ (pointer, IT.mul_ (it_q, step) (IT.get_loc step)) loc in let arg_its = it_p :: iargs in let args = List.combine arg_syms arg_its in (* Build [GT.t] *) @@ -261,7 +261,7 @@ let rec compile_it_lat let it_ret = IT.record_ (List.map_fst (fun sym -> Id.id (Sym.pp_string sym)) it_oargs) here in - return (GT.return_ it_ret (IT.loc it)) + return (GT.return_ it_ret (IT.get_loc it)) in return (f_gt_init gt) diff --git a/backend/cn/lib/testGeneration/genDistribute.ml b/backend/cn/lib/testGeneration/genDistribute.ml index 3a1cbc798..42056f14f 100644 --- a/backend/cn/lib/testGeneration/genDistribute.ml +++ b/backend/cn/lib/testGeneration/genDistribute.ml @@ -44,14 +44,15 @@ let apply_array_max_length (gt : GT.t) : GT.t = let loc = Locations.other __LOC__ in let it_max_min = IT.le_ - ( IT.num_lit_ (Z.of_int 0) (IT.bt it_max) loc, - IT.add_ (it_max, IT.num_lit_ Z.one (IT.bt it_max) loc) loc ) + ( IT.num_lit_ (Z.of_int 0) (IT.get_bt it_max) loc, + IT.add_ (it_max, IT.num_lit_ Z.one (IT.get_bt it_max) loc) loc ) loc in let it_max_max = IT.lt_ ( it_max, - IT.num_lit_ (Z.of_int (Config.get_max_array_length ())) (IT.bt it_max) loc ) + IT.num_lit_ (Z.of_int (Config.get_max_array_length ())) (IT.get_bt it_max) loc + ) loc in GT.assert_ diff --git a/backend/cn/lib/testGeneration/genNormalize.ml b/backend/cn/lib/testGeneration/genNormalize.ml index 34946c9ec..4389789e9 100644 --- a/backend/cn/lib/testGeneration/genNormalize.ml +++ b/backend/cn/lib/testGeneration/genNormalize.ml @@ -142,7 +142,7 @@ module MemberIndirection = struct indirect_map |> List.map (fun (y, z) -> let it = List.assoc Id.equal y xits in - (y, IT.sym_ (z, IT.bt it, IT.loc it))) + (y, IT.sym_ (z, IT.get_bt it, IT.get_loc it))) in match k with | Struct tag -> IT.struct_ (tag, members) loc_it diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 5819f2f56..b25802e8f 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -293,7 +293,7 @@ module Fusion = struct loc, reqs ) else ( - let old_args = List.map_snd IT.bt xits in + let old_args = List.map_snd IT.get_bt xits in let ret_sym = Sym.fresh_make_uniq (Sym.pp_string x) in let xits' = lcs @@ -314,11 +314,11 @@ module Fusion = struct :: (xits' |> List.map (fun (y, it) -> ( fst (Option.get (IT.is_sym it)), - IT.sym_ (y, IT.bt it, Locations.other __LOC__) ))) + IT.sym_ (y, IT.get_bt it, Locations.other __LOC__) ))) in let lcs = List.map (LC.subst (IT.make_subst subst)) lcs in let new_name = Sym.fresh_make_uniq (Sym.pp_string fsym) in - let new_args = xits' |> List.map (fun (y, it) -> (y, IT.bt it)) in + let new_args = xits' |> List.map (fun (y, it) -> (y, IT.get_bt it)) in ( GT.let_ ( backtracks, (x, GT.call_ (new_name, xits @ xits') bt_call loc_call), @@ -758,7 +758,7 @@ module PartialEvaluation = struct eval_aux (good_value struct_decls ty it' here) | Aligned { t; align } -> let addr = addr_ t here in - if not (BT.equal (IT.bt addr) (IT.bt align)) then + if not (BT.equal (IT.get_bt addr) (IT.get_bt align)) then Error "Mismatched types" else eval_aux (divisible_ (addr, align) here) @@ -1254,7 +1254,7 @@ module BranchPruning = struct if contains_false_assertion gt_else then GT.assert_ (T it_if, gt_then) loc_ite else if contains_false_assertion gt_then then - GT.assert_ (T (IT.not_ it_if (IT.loc it_if)), gt_else) loc_ite + GT.assert_ (T (IT.not_ it_if (IT.get_loc it_if)), gt_else) loc_ite else gt | _ -> gt @@ -1473,7 +1473,7 @@ module SplitConstraints = struct | Assert (T (IT (Let ((x, it_inner), it_rest), _, loc_let)), gt') -> GT.let_ ( 0, - (x, GT.return_ it_inner (IT.loc it_inner)), + (x, GT.return_ it_inner (IT.get_loc it_inner)), GT.assert_ (LC.T it_rest, gt') loc ) loc_let | Assert (Forall ((_i_sym, _i_bt), IT (Let _, _, _)), _) -> diff --git a/backend/cn/lib/testGeneration/genTerms.ml b/backend/cn/lib/testGeneration/genTerms.ml index 6d6accd72..8e24db588 100644 --- a/backend/cn/lib/testGeneration/genTerms.ml +++ b/backend/cn/lib/testGeneration/genTerms.ml @@ -52,7 +52,7 @@ let let_ ((retries, (x, gt1), gt2) : int * (Sym.t * t) * t) (loc : Locations.t) GT (Let (retries, (x, gt1), gt2), basetype gt2, loc) -let return_ (it : IT.t) (loc : Locations.t) : t = GT (Return it, IT.bt it, loc) +let return_ (it : IT.t) (loc : Locations.t) : t = GT (Return it, IT.get_bt it, loc) let assert_ ((lc, gt') : LC.t * t) (loc : Locations.t) : t = GT (Assert (lc, gt'), basetype gt', loc) diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index bb5fd5454..f344982fb 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -595,11 +595,11 @@ let pp_message te = Some (squotes (IT.pp left) ^^^ !^"has type" - ^^^ squotes (BaseTypes.Surface.pp (IT.bt left)) + ^^^ squotes (BaseTypes.Surface.pp (IT.get_bt left)) ^^ comma ^^^ squotes (IT.pp right) ^^^ !^"has type" - ^^^ squotes (BaseTypes.Surface.pp (IT.bt right)) + ^^^ squotes (BaseTypes.Surface.pp (IT.get_bt right)) ^^ dot) in { short; descr; state = None } diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index a5377aa66..a277ba030 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -589,11 +589,11 @@ let bind_logical_return_internal loc = let rec aux members lrt = match (members, lrt) with | member :: members, LogicalReturnTypes.Define ((s, it), _, lrt) -> - let@ () = ensure_base_type loc ~expect:(IT.bt it) (IT.bt member) in + let@ () = ensure_base_type loc ~expect:(IT.get_bt it) (IT.get_bt member) in let@ () = add_c_internal (LC.T (IT.eq__ member it loc)) in aux members (LogicalReturnTypes.subst (IT.make_subst [ (s, member) ]) lrt) | member :: members, Resource ((s, (re, bt)), _, lrt) -> - let@ () = ensure_base_type loc ~expect:bt (IT.bt member) in + let@ () = ensure_base_type loc ~expect:bt (IT.get_bt member) in let@ () = add_r_internal loc (re, Res.O member) in aux members (LogicalReturnTypes.subst (IT.make_subst [ (s, member) ]) lrt) | members, Constraint (lc, _, lrt) -> @@ -614,7 +614,7 @@ let bind_logical_return loc members lrt = let bind_return loc members (rt : ReturnTypes.t) = match (members, rt) with | member :: members, Computational ((s, bt), _, lrt) -> - let@ () = ensure_base_type loc ~expect:bt (IT.bt member) in + let@ () = ensure_base_type loc ~expect:bt (IT.get_bt member) in let@ () = bind_logical_return loc diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 527f33f96..c1c62965c 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -51,60 +51,60 @@ let ensure_z_fits_bits_type loc (sign, n) v = let ensure_arith_type ~reason it = let open BT in - match IT.bt it with + match IT.get_bt it with | Integer | Real | Bits _ -> return () | _ -> let expected = "integer, real or bitvector type" in fail (illtyped_index_term - (IT.loc it) + (IT.get_loc it) it - (IT.bt it) + (IT.get_bt it) ~expected ~reason:(Either.Left reason)) let ensure_set_type ~reason it = let open BT in - match IT.bt it with + match IT.get_bt it with | Set bt -> return bt | _ -> let expected = "set" in fail (illtyped_index_term - (IT.loc it) + (IT.get_loc it) it - (IT.bt it) + (IT.get_bt it) ~expected ~reason:(Either.Left reason)) let ensure_list_type ~reason it = let open BT in - match IT.bt it with + match IT.get_bt it with | List bt -> return bt | _ -> let expected = "list" in fail (illtyped_index_term - (IT.loc it) + (IT.get_loc it) it - (IT.bt it) + (IT.get_bt it) ~expected ~reason:(Either.Left reason)) let ensure_map_type ~reason it = let open BT in - match IT.bt it with + match IT.get_bt it with | Map (abt, rbt) -> return (abt, rbt) | _ -> let expected = "map/array" in fail (illtyped_index_term - (IT.loc it) + (IT.get_loc it) it - (IT.bt it) + (IT.get_bt it) ~expected ~reason:(Either.Left reason)) @@ -367,7 +367,7 @@ module WIT = struct let@ def = Typing.get_logical_function_def loc name in return def.loc | IT ((MapSet (t, _, _) | Let (_, t)), _, _) -> get_location_for_type t - | IT (Cons (it, _), _, _) | it -> return @@ IT.loc it + | IT (Cons (it, _), _, _) | it -> return @@ IT.get_loc it (* NOTE: This cannot _check_ what the root type of term is (the type is @@ -418,11 +418,11 @@ module WIT = struct | Negate -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - return (t, IT.bt t) + return (t, IT.get_bt t) | BW_CLZ_NoSMT | BW_CTZ_NoSMT | BW_FFS_NoSMT | BW_FLS_NoSMT | BW_Compl -> let@ t = infer t in - let@ () = ensure_bits_type (IT.loc t) (IT.bt t) in - return (t, IT.bt t) + let@ () = ensure_bits_type (IT.get_loc t) (IT.get_bt t) in + return (t, IT.get_bt t) in return (IT (Unop (unop, t), ret_bt, loc)) | Binop (arith_op, t, t') -> @@ -430,18 +430,18 @@ module WIT = struct | Add -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (Add, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (Add, t, t'), IT.get_bt t, loc)) | Sub -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (Sub, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (Sub, t, t'), IT.get_bt t, loc)) | Mul -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - (match (IT.bt t, is_const t, is_const t') with + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + (match (IT.get_bt t, is_const t, is_const t') with | Integer, None, None -> let msg = !^"Both sides of the integer multiplication" @@ -450,18 +450,18 @@ module WIT = struct ^^^ !^"treating the term as uninterpreted." in warn loc msg; - return (IT (Binop (MulNoSMT, t, t'), IT.bt t, loc)) - | _ -> return (IT (Binop (Mul, t, t'), IT.bt t, loc))) + return (IT (Binop (MulNoSMT, t, t'), IT.get_bt t, loc)) + | _ -> return (IT (Binop (Mul, t, t'), IT.get_bt t, loc))) | MulNoSMT -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (MulNoSMT, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (MulNoSMT, t, t'), IT.get_bt t, loc)) | Div -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - (match (IT.bt t, is_const t') with + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + (match (IT.get_bt t, is_const t') with | Integer, Some (Z z', _) when Z.leq z' Z.zero -> let msg = !^"Division" @@ -470,7 +470,7 @@ module WIT = struct ^^^ !^"Treating as uninterpreted." in warn loc msg; - return (IT (Binop (DivNoSMT, t, t'), IT.bt t, loc)) + return (IT (Binop (DivNoSMT, t, t'), IT.get_bt t, loc)) | Integer, None -> let msg = !^"Division" @@ -479,55 +479,55 @@ module WIT = struct ^^^ !^"Treating as uninterpreted." in warn loc msg; - return (IT (Binop (DivNoSMT, t, t'), IT.bt t, loc)) + return (IT (Binop (DivNoSMT, t, t'), IT.get_bt t, loc)) | _ -> (* TODO: check for a zero divisor *) - return (IT (Binop (Div, t, t'), IT.bt t, loc))) + return (IT (Binop (Div, t, t'), IT.get_bt t, loc))) | DivNoSMT -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (DivNoSMT, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (DivNoSMT, t, t'), IT.get_bt t, loc)) | Exp -> let@ t = infer t in - let@ () = ensure_bits_type loc (IT.bt t) in - let@ t' = check (IT.loc t) (IT.bt t) t' in + let@ () = ensure_bits_type loc (IT.get_bt t) in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in let msg = !^"Treating exponentiation" ^^^ squotes (IT.pp (exp_ (t, t') loc)) ^^^ !^"as uninterpreted." in warn loc msg; - return (IT (Binop (ExpNoSMT, t, t'), IT.bt t, loc)) + return (IT (Binop (ExpNoSMT, t, t'), IT.get_bt t, loc)) | ExpNoSMT | RemNoSMT | ModNoSMT | BW_Xor | BW_And | BW_Or | ShiftLeft | ShiftRight | Rem | Mod -> let@ t = infer t in - let@ () = ensure_bits_type loc (IT.bt t) in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (arith_op, t, t'), IT.bt t, loc)) + let@ () = ensure_bits_type loc (IT.get_bt t) in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (arith_op, t, t'), IT.get_bt t, loc)) | LT -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in return (IT (Binop (LT, t, t'), BT.Bool, loc)) | LE -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in return (IT (Binop (LE, t, t'), BT.Bool, loc)) | Min -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (Min, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (Min, t, t'), IT.get_bt t, loc)) | Max -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (Max, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (Max, t, t'), IT.get_bt t, loc)) | EQ -> let@ t = infer t in - let@ t' = check (IT.loc t) (IT.bt t) t' in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in return (IT (Binop (EQ, t, t'), BT.Bool, loc)) | LTPointer -> let@ t = check loc (Loc ()) t in @@ -539,18 +539,18 @@ module WIT = struct return (IT (Binop (LEPointer, t, t'), BT.Bool, loc)) | SetMember -> let@ t = infer t in - let@ t' = check loc (Set (IT.bt t)) t' in + let@ t' = check loc (Set (IT.get_bt t)) t' in return (IT (Binop (SetMember, t, t'), BT.Bool, loc)) | SetUnion -> let@ t = infer t in let@ _itembt = ensure_set_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (SetUnion, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (SetUnion, t, t'), IT.get_bt t, loc)) | SetIntersection -> let@ t = infer t in let@ _itembt = ensure_set_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (SetIntersection, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (SetIntersection, t, t'), IT.get_bt t, loc)) | SetDifference -> let@ t = infer t in let@ itembt = ensure_set_type ~reason:loc t in @@ -559,7 +559,7 @@ module WIT = struct | Subset -> let@ t = infer t in let@ itembt = ensure_set_type ~reason:loc t in - let@ t' = check (IT.loc t) (Set itembt) t' in + let@ t' = check (IT.get_loc t) (Set itembt) t' in return (IT (Binop (Subset, t, t'), BT.Bool, loc)) | And -> let@ t = check loc Bool t in @@ -576,8 +576,8 @@ module WIT = struct | ITE (t, t', t'') -> let@ t = check loc Bool t in let@ t' = infer t' in - let@ t'' = check (IT.loc t') (IT.bt t') t'' in - return (IT (ITE (t, t', t''), IT.bt t', loc)) + let@ t'' = check (IT.get_loc t') (IT.get_bt t') t'' in + return (IT (ITE (t, t', t''), IT.get_bt t', loc)) | EachI ((i1, (s, bt), i2), t) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure @@ -591,12 +591,12 @@ module WIT = struct return (IT (EachI ((i1, (s, bt), i2), t), BT.Bool, loc))) | Tuple ts -> let@ ts = ListM.mapM infer ts in - let bts = List.map IT.bt ts in + let bts = List.map IT.get_bt ts in return (IT (Tuple ts, BT.Tuple bts, loc)) | NthTuple (n, t') -> let@ t' = infer t' in let@ item_bt = - match IT.bt t' with + match IT.get_bt t' with | Tuple bts -> (match List.nth_opt bts n with | Some t -> return t @@ -636,7 +636,7 @@ module WIT = struct | StructMember (t, member) -> let@ t = infer t in let@ tag = - match IT.bt t with + match IT.get_bt t with | Struct tag -> return tag | has -> let expected = "struct" in @@ -648,16 +648,16 @@ module WIT = struct | StructUpdate ((t, member), v) -> let@ t = infer t in let@ tag = - match IT.bt t with + match IT.get_bt t with | Struct tag -> return tag | has -> (* this case should have been caught by compile.ml *) let expected = "struct" in - let reason = Either.Left (IT.loc t) in + let reason = Either.Left (IT.get_loc t) in fail (illtyped_index_term loc t has ~expected ~reason) in let@ field_ct = get_struct_member_type loc tag member in - let@ v = check (IT.loc t) (Memory.bt_of_sct field_ct) v in + let@ v = check (IT.get_loc t) (Memory.bt_of_sct field_ct) v in return (IT (StructUpdate ((t, member), v), BT.Struct tag, loc)) | Record members -> assert (List.sorted_and_unique compare_by_fst_id members); @@ -668,12 +668,12 @@ module WIT = struct return (id, t)) members in - let member_types = List.map (fun (id, t) -> (id, IT.bt t)) members in + let member_types = List.map (fun (id, t) -> (id, IT.get_bt t)) members in return (IT (IT.Record members, BT.Record member_types, loc)) | RecordMember (t, member) -> let@ t = infer t in let@ members = - match IT.bt t with + match IT.get_bt t with | Record members -> return members | has -> let expected = "struct" in @@ -686,13 +686,13 @@ module WIT = struct | None -> let expected = "struct with member " ^ Id.pp_string member in let reason = Either.Left loc in - fail (illtyped_index_term loc t (IT.bt t) ~expected ~reason) + fail (illtyped_index_term loc t (IT.get_bt t) ~expected ~reason) in return (IT (RecordMember (t, member), bt, loc)) | RecordUpdate ((t, member), v) -> let@ t = infer t in let@ members = - match IT.bt t with + match IT.get_bt t with | Record members -> return members | has -> let expected = "struct" in @@ -705,15 +705,15 @@ module WIT = struct | None -> let expected = "struct with member " ^ Id.pp_string member in let reason = Either.Left loc in - fail (illtyped_index_term loc t (IT.bt t) ~expected ~reason) + fail (illtyped_index_term loc t (IT.get_bt t) ~expected ~reason) in - let@ v = check (IT.loc t) bt v in - return (IT (RecordUpdate ((t, member), v), IT.bt t, loc)) + let@ v = check (IT.get_loc t) bt v in + return (IT (RecordUpdate ((t, member), v), IT.get_bt t, loc)) | Cast (cbt, t) -> let@ cbt = WBT.is_bt loc cbt in let@ t = infer t in let@ () = - match (IT.bt t, cbt) with + match (IT.get_bt t, cbt) with | Integer, Loc () -> fail (fun _ -> { loc; @@ -754,7 +754,7 @@ module WIT = struct let@ () = WCT.is_ct loc ct in let@ base = check loc (Loc ()) base in let@ index = infer index in - let@ () = ensure_bits_type loc (IT.bt index) in + let@ () = ensure_bits_type loc (IT.get_bt index) in return (IT (ArrayShift { base; ct; index }, BT.Loc (), loc)) | CopyAllocId { addr; loc = ptr } -> let@ addr = check loc Memory.uintptr_bt addr in @@ -797,8 +797,8 @@ module WIT = struct return (IT (Nil bt, BT.List bt, loc)) | Cons (t1, t2) -> let@ t1 = infer t1 in - let t1_loc = IT.loc t1 in - let t1_bt = IT.bt t1 in + let t1_loc = IT.get_loc t1 in + let t1_bt = IT.get_bt t1 in (* This is all a little more complicated than ideal because we use the type of the first element of a list literal (currently always non-empty) is used to annotate the (Nil bt), and so _its_ location is the one which must be passed to @@ -835,19 +835,19 @@ module WIT = struct return (IT (Tail t, BT.List bt, loc)) | NthList (i, xs, d) -> let@ i = infer i in - let@ () = ensure_bits_type loc (IT.bt i) in + let@ () = ensure_bits_type loc (IT.get_bt i) in let@ xs = infer xs in let@ bt = ensure_list_type xs ~reason:loc in - let@ d = check (IT.loc xs) bt d in + let@ d = check (IT.get_loc xs) bt d in return (IT (NthList (i, xs, d), bt, loc)) | ArrayToList (arr, i, len) -> let@ i = infer i in - let@ () = ensure_bits_type loc (IT.bt i) in - let@ len = check (IT.loc i) (IT.bt i) len in + let@ () = ensure_bits_type loc (IT.get_bt i) in + let@ len = check (IT.get_loc i) (IT.get_bt i) len in let@ arr = infer arr in let@ ix_bt, bt = ensure_map_type ~reason:loc arr in let@ () = - if BT.equal ix_bt (IT.bt i) then + if BT.equal ix_bt (IT.get_bt i) then return () else fail (fun _ -> @@ -863,17 +863,17 @@ module WIT = struct | MapConst (index_bt, t) -> let@ index_bt = WBT.is_bt loc index_bt in let@ t = infer t in - return (IT (MapConst (index_bt, t), BT.Map (index_bt, IT.bt t), loc)) + return (IT (MapConst (index_bt, t), BT.Map (index_bt, IT.get_bt t), loc)) | MapSet (t1, t2, t3) -> let@ t1 = infer t1 in let@ abt, rbt = ensure_map_type ~reason:loc t1 in - let@ t2 = check (IT.loc t1) abt t2 in - let@ t3 = check (IT.loc t1) rbt t3 in - return (IT (MapSet (t1, t2, t3), IT.bt t1, loc)) + let@ t2 = check (IT.get_loc t1) abt t2 in + let@ t3 = check (IT.get_loc t1) rbt t3 in + return (IT (MapSet (t1, t2, t3), IT.get_bt t1, loc)) | MapGet (t, arg) -> let@ t = infer t in let@ abt, bt = ensure_map_type ~reason:loc t in - let@ arg = check (IT.loc t) abt arg in + let@ arg = check (IT.get_loc t) abt arg in return (IT (MapGet (t, arg), bt, loc)) | MapDef ((s, abt), body) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) @@ -881,7 +881,7 @@ module WIT = struct pure (let@ () = add_l s abt (loc, lazy (Pp.string "map-def-var")) in let@ body = infer body in - return (IT (MapDef ((s, abt), body), Map (abt, IT.bt body), loc))) + return (IT (MapDef ((s, abt), body), Map (abt, IT.get_bt body), loc))) | Apply (name, args) -> let@ def = Typing.get_logical_function_def loc name in let has_args, expect_args = (List.length args, List.length def.args) in @@ -898,10 +898,10 @@ module WIT = struct | Let ((name, t1), t2) -> let@ t1 = infer t1 in pure - (let@ () = add_l name (IT.bt t1) (loc, lazy (Pp.string "let-var")) in + (let@ () = add_l name (IT.get_bt t1) (loc, lazy (Pp.string "let-var")) in let@ () = add_c loc (LC.T (IT.def_ name t1 loc)) in let@ t2 = infer t2 in - return (IT (Let ((name, t1), t2), IT.bt t2, loc))) + return (IT (Let ((name, t1), t2), IT.get_bt t2, loc))) | Constructor (s, args) -> let@ info = get_datatype_constr loc s in let@ args_annotated = correct_members_sorted_annotated loc info.params args in @@ -920,16 +920,16 @@ module WIT = struct ListM.fold_leftM (fun (rbt, acc) (pat, body) -> pure - (let@ pat = check_and_bind_pattern (IT.bt e) pat in + (let@ pat = check_and_bind_pattern (IT.get_bt e) pat in let@ body = match rbt with None -> infer body | Some rbt -> check loc rbt body in - return (Some (IT.bt body), acc @ [ (pat, body) ]))) + return (Some (IT.get_bt body), acc @ [ (pat, body) ]))) (None, []) cases in let@ () = - cases_complete loc [ IT.bt e ] (List.map (fun (pat, _) -> [ pat ]) cases) + cases_complete loc [ IT.get_bt e ] (List.map (fun (pat, _) -> [ pat ]) cases) in let@ () = cases_necessary (List.map (fun (pat, _) -> pat) cases) in let@ rbt = @@ -947,12 +947,12 @@ module WIT = struct let@ ls = WBT.is_bt expect_loc expect_ls in let@ it = infer it in let@ loc = get_location_for_type it in - if BT.equal ls (IT.bt it) then + if BT.equal ls (IT.get_bt it) then return it else ( let expected = Pp.plain @@ BT.pp ls in let reason = Either.Left expect_loc in - fail (illtyped_index_term loc it (IT.bt it) ~expected ~reason)) + fail (illtyped_index_term loc it (IT.get_bt it) ~expected ~reason)) end let quantifier_bt = BT.Bits (Unsigned, 64) @@ -1136,7 +1136,7 @@ module WLRT = struct | Define ((s, it), ((loc, _) as info), lrt) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ it = WIT.infer it in - let@ () = add_l s (IT.bt it) (loc, lazy (Pp.string "let-var")) in + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in let@ lrt = aux lrt in return (Define ((s, it), info, lrt)) @@ -1214,7 +1214,7 @@ module WLAT = struct | LAT.Define ((s, it), info, at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ it = WIT.infer it in - let@ () = add_l s (IT.bt it) (loc, lazy (Pp.string "let-var")) in + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in let@ at = aux at in return (LAT.Define ((s, it), info, at)) @@ -1300,7 +1300,7 @@ module WLArgs = struct | Mu.Define ((s, it), ((loc, _) as info), at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ it = WIT.infer it in - let@ () = add_l s (IT.bt it) (loc, lazy (Pp.string "let-var")) in + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in let@ at = aux at in return (Mu.Define ((s, it), info, at)) @@ -1857,8 +1857,8 @@ module BaseTyping = struct let@ it = WIT.infer it in warn_when_not_quantifier_bt "extract" - (IT.loc it) - (IT.bt it) + (IT.get_loc it) + (IT.get_bt it) (Some (IndexTerms.pp it)); return (Extract (attrs, to_extract, it)) | Unfold (f, its) -> From 7acdd5f1c572e7a87c9749579fd8d020f32ae127 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 25 Dec 2024 14:37:12 +0000 Subject: [PATCH 122/148] CN: Tidy up some variable names With the previous commit, some shorter renames are now possible, such as basetype => get_bt, and loc' => loc. --- backend/cn/lib/alloc.ml | 16 ++--- backend/cn/lib/builtins.ml | 20 +++---- backend/cn/lib/cn_internal_to_ail.ml | 4 +- backend/cn/lib/compile.ml | 27 ++++----- backend/cn/lib/indexTerms.ml | 16 +++-- backend/cn/lib/pack.ml | 28 ++++----- backend/cn/lib/simplify.ml | 2 +- backend/cn/lib/solver.ml | 89 ++++++++++++++-------------- 8 files changed, 96 insertions(+), 106 deletions(-) diff --git a/backend/cn/lib/alloc.ml b/backend/cn/lib/alloc.ml index 7de84e61d..d4241ecbe 100644 --- a/backend/cn/lib/alloc.ml +++ b/backend/cn/lib/alloc.ml @@ -13,18 +13,18 @@ module History = struct let value_bt = BaseTypes.Record [ (base_id, base_bt); (size_id, size_bt) ] - let make_value ~base ~size loc' = + let make_value ~base ~size loc = IndexTerms.( - record_ [ (base_id, base); (size_id, num_lit_ (Z.of_int size) size_bt loc') ] loc') + record_ [ (base_id, base); (size_id, num_lit_ (Z.of_int size) size_bt loc) ] loc) let bt = BaseTypes.Map (Alloc_id, value_bt) - let it loc' = IndexTerms.sym_ (sym, bt, loc') + let it loc = IndexTerms.sym_ (sym, bt, loc) - let lookup_ptr ptr loc' = + let lookup_ptr ptr loc = assert (BaseTypes.(equal (IndexTerms.get_bt ptr) (Loc ()))); - IndexTerms.(map_get_ (it loc') (allocId_ ptr loc') loc') + IndexTerms.(map_get_ (it loc) (allocId_ ptr loc) loc) type value = @@ -32,10 +32,10 @@ module History = struct size : IndexTerms.t } - let split value loc' = + let split value loc = IndexTerms. - { base = recordMember_ ~member_bt:base_bt (value, base_id) loc'; - size = recordMember_ ~member_bt:size_bt (value, size_id) loc' + { base = recordMember_ ~member_bt:base_bt (value, base_id) loc; + size = recordMember_ ~member_bt:size_bt (value, size_id) loc } diff --git a/backend/cn/lib/builtins.ml b/backend/cn/lib/builtins.ml index 87d90d6f5..6d6af1ebf 100644 --- a/backend/cn/lib/builtins.ml +++ b/backend/cn/lib/builtins.ml @@ -138,40 +138,38 @@ let array_to_list_def = let is_null_def = ( "is_null", Sym.fresh_named "is_null", - mk_arg1 (fun p loc' -> IT.Surface.inj IT.(eq_ (IT.Surface.proj p, null_ loc') loc')) - ) + mk_arg1 IT.(fun p loc -> Surface.inj (eq_ (Surface.proj p, null_ loc) loc)) ) let has_alloc_id_def = ( "has_alloc_id", Sym.fresh_named "has_alloc_id", - mk_arg1 (fun p loc' -> IT.Surface.inj @@ IT.hasAllocId_ (IT.Surface.proj p) loc') ) + mk_arg1 IT.(fun p loc -> Surface.inj @@ hasAllocId_ (Surface.proj p) loc) ) let ptr_eq_def = ( "ptr_eq", Sym.fresh_named "ptr_eq", - mk_arg2 (fun (p1, p2) loc' -> - IT.(Surface.inj @@ eq_ (Surface.proj p1, Surface.proj p2) loc')) ) + mk_arg2 (fun (p1, p2) loc -> + IT.(Surface.inj @@ eq_ (Surface.proj p1, Surface.proj p2) loc)) ) let prov_eq_def = ( "prov_eq", Sym.fresh_named "prov_eq", - mk_arg2 (fun (p1, p2) loc' -> + mk_arg2 (fun (p1, p2) loc -> IT.( Surface.inj - @@ eq_ (allocId_ (Surface.proj p1) loc', allocId_ (Surface.proj p2) loc') loc')) - ) + @@ eq_ (allocId_ (Surface.proj p1) loc, allocId_ (Surface.proj p2) loc) loc)) ) let addr_eq_def = ( "addr_eq", Sym.fresh_named "addr_eq", - mk_arg2 (fun (p1, p2) loc' -> + mk_arg2 (fun (p1, p2) loc -> IT.( - Surface.inj - @@ eq_ (addr_ (Surface.proj p1) loc', addr_ (Surface.proj p2) loc') loc')) ) + Surface.inj @@ eq_ (addr_ (Surface.proj p1) loc, addr_ (Surface.proj p2) loc) loc)) + ) let max_min_bits = diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 7a8b91af5..7db0b5291 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -832,7 +832,7 @@ let rec cn_to_ail_expr_aux_internal let b2, s2, e2 = cn_to_ail_expr_aux_internal const_prop pred_name dts globals t2 PassBack in - let ail_bop, annot = cn_to_ail_binop_internal (IT.basetype t1) (IT.basetype t2) bop in + let ail_bop, annot = cn_to_ail_binop_internal (IT.get_bt t1) (IT.get_bt t2) bop in let str = match annot with Some str -> str | None -> failwith "No CN binop function found" in @@ -1293,7 +1293,7 @@ let rec cn_to_ail_expr_aux_internal match ps with | T.(Pat (PSym sym', p_bt, pt_loc)) :: ps' -> ( mk_pattern T.PWild p_bt pt_loc :: ps', - T.(IT (Let ((sym', t1), t2), IT.basetype t2, pt_loc)) ) + T.(IT (Let ((sym', t1), t2), IT.get_bt t2, pt_loc)) ) | p :: ps' -> (p :: ps', t2) | [] -> assert false in diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 4fb14020e..b00e2c4d7 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -446,12 +446,11 @@ module EffectfulTranslation = struct (* TODO: type checks and disambiguation at this stage seems ill-advised, ideally would be integrated into wellTyped.ml *) - let mk_translate_binop loc' bop (e1, e2) = + let mk_translate_binop loc bop (e1, e2) = let open IndexTerms in - let loc = loc' in - match (bop, IT.get_bt e1) with + match (bop, get_bt e1) with | CN_add, (BT.Integer | Real | Bits _) -> - return (IT (Binop (Add, e1, e2), IT.get_bt e1, loc)) + return (IT (Binop (Add, e1, e2), get_bt e1, loc)) | CN_add, Loc oct -> (match oct with | Some ct -> @@ -462,7 +461,7 @@ module EffectfulTranslation = struct return (IT (it_, Loc oct, loc)) | None -> cannot_tell_pointee_ctype loc e1) | CN_sub, (Integer | Real | Bits _) -> - return (IT (Binop (Sub, e1, e2), IT.get_bt e1, loc)) + return (IT (Binop (Sub, e1, e2), get_bt e1, loc)) | CN_sub, Loc oct -> (match oct with | Some ct -> @@ -477,11 +476,11 @@ module EffectfulTranslation = struct in return (IT (it_, Loc oct, loc)) | None -> cannot_tell_pointee_ctype loc e1) - | CN_mul, _ -> return (IT (Binop (Mul, e1, e2), IT.get_bt e1, loc)) - | CN_div, _ -> return (IT (Binop (Div, e1, e2), IT.get_bt e1, loc)) - | CN_mod, _ -> return (IT (Binop (Rem, e1, e2), IT.get_bt e1, loc)) + | CN_mul, _ -> return (IT (Binop (Mul, e1, e2), get_bt e1, loc)) + | CN_div, _ -> return (IT (Binop (Div, e1, e2), get_bt e1, loc)) + | CN_mod, _ -> return (IT (Binop (Rem, e1, e2), get_bt e1, loc)) | CN_equal, _ -> - (match (IT.get_bt e1, IT.get_bt e2, !pointer_eq_warned) with + (match (get_bt e1, get_bt e2, !pointer_eq_warned) with | Loc _, Loc _, false -> pointer_eq_warned := true; Pp.warn @@ -491,7 +490,7 @@ module EffectfulTranslation = struct | _, _, _ -> ()); return (IT (Binop (EQ, e1, e2), BT.Bool, loc)) | CN_inequal, _ -> - (match (IT.get_bt e1, IT.get_bt e2, !pointer_eq_warned) with + (match (get_bt e1, get_bt e2, !pointer_eq_warned) with | Loc _, Loc _, false -> pointer_eq_warned := true; Pp.warn @@ -517,7 +516,7 @@ module EffectfulTranslation = struct | CN_implies, BT.Bool -> return (IT (Binop (Implies, e1, e2), BT.Bool, loc)) | CN_map_get, _ -> let@ rbt = - match IT.get_bt e1 with + match get_bt e1 with | Map (_, rbt) -> return rbt | has -> let expected = "map/array" in @@ -651,7 +650,7 @@ module EffectfulTranslation = struct return (IT (Sym sym, bTy, loc)) | CNExpr_list es -> let@ es = ListM.mapM self es in - let item_bt = basetype (List.hd es) in + let item_bt = get_bt (List.hd es) in let _, nil_pos, _ = (* parser should ensure loc is a region *) Option.get @@ Locations.get_region loc @@ -885,7 +884,7 @@ module EffectfulTranslation = struct return (pat, body)) ms in - let rbt = IT.basetype (snd (List.hd ms)) in + let rbt = IT.get_bt (snd (List.hd ms)) in return (IT (Match (x, ms), rbt, loc)) | CNExpr_let (s, e, body) -> let@ e = self e in @@ -1358,7 +1357,7 @@ let translate_cn_clause env clause = | CN_letExpr (loc, sym, e_, cl) -> let@ e = handle st (ET.translate_cn_expr Sym.Set.empty env e_) in let acc' z = acc (LAT.mDefine (sym, IT.Surface.proj e, (loc, None)) z) in - translate_cn_clause_aux (add_logical sym (IT.basetype e) env) st acc' cl + translate_cn_clause_aux (add_logical sym (IT.get_bt e) env) st acc' cl | CN_assert (loc, assrt, cl) -> let@ lc = handle st (ET.translate_cn_assrt env (loc, assrt)) in let acc' z = acc (LAT.mConstraint (lc, (loc, None)) z) in diff --git a/backend/cn/lib/indexTerms.ml b/backend/cn/lib/indexTerms.ml index 6e78f8710..731b4c0ae 100644 --- a/backend/cn/lib/indexTerms.ml +++ b/backend/cn/lib/indexTerms.ml @@ -22,9 +22,7 @@ module Surface = struct let inj x = Terms.map_annot BaseTypes.Surface.inj x end -let basetype : 'a. 'a annot -> 'a = function IT (_, bt, _) -> bt - -let get_bt = basetype +let get_bt : 'a. 'a annot -> 'a = function IT (_, bt, _) -> bt let get_term (IT (t, _, _)) = t @@ -205,7 +203,7 @@ let rec fold_ f binders acc = function let acc' = fold f binders acc t1 in (* TODO - add location information to binders *) let here = Locations.other __FUNCTION__ in - fold f (binders @ [ (Pat (PSym nm, basetype t1, here), Some t1) ]) acc' t2 + fold f (binders @ [ (Pat (PSym nm, get_bt t1, here), Some t1) ]) acc' t2 | Match (e, cases) -> (* TODO: check this is good *) let acc' = fold f binders acc e in @@ -280,7 +278,7 @@ let rec subst (su : [ `Term of t | `Rename of Sym.t ] Subst.t) (IT (it, bt, loc) | Sym sym -> (match List.assoc_opt Sym.equal sym su.replace with | Some (`Term after) -> - if BT.equal bt (basetype after) then + if BT.equal bt (get_bt after) then () else failwith @@ -580,7 +578,7 @@ let or_sterm_ its loc = vargs_binop (bool_sterm_ true loc) (Tools.curry (fun p -> or2_sterm_ p loc)) its -let let_ ((nm, x), y) loc = IT (Let ((nm, x), y), basetype y, loc) +let let_ ((nm, x), y) loc = IT (Let ((nm, x), y), get_bt y, loc) (* let disperse_not_ it = *) (* match term it with *) @@ -696,7 +694,7 @@ let ( %. ) struct_decls t member = let record_ members loc = - IT (Record members, BT.Record (List.map (fun (s, t) -> (s, basetype t)) members), loc) + IT (Record members, BT.Record (List.map (fun (s, t) -> (s, get_bt t)) members), loc) let recordMember_ ~member_bt (t, member) loc = @@ -1082,8 +1080,8 @@ let rec wrap_bindings_match bs default_v v = (IT ( Match ( match_e, - [ (pat, v2); (Pat (PWild, basetype match_e, here), default_v) ] ), - basetype v2, + [ (pat, v2); (Pat (PWild, get_bt match_e, here), default_v) ] ), + get_bt v2, here )))) diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index 2274ef238..9ae3b8e69 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -21,21 +21,19 @@ let resource_empty provable resource = | `False -> `NonEmpty (constr, Solver.model ()) -let unfolded_array loc' init (ict, olength) pointer = +let unfolded_array loc init (ict, olength) pointer = let length = Option.get olength in - let q_s, q = IT.fresh_named Memory.uintptr_bt "i" loc' in + let q_s, q = IT.fresh_named Memory.uintptr_bt "i" loc in Q { name = Owned (ict, init); pointer; q = (q_s, Memory.uintptr_bt); - q_loc = loc'; - step = IT.uintptr_int_ (Memory.size_of_ctype ict) loc'; + q_loc = loc; + step = IT.uintptr_int_ (Memory.size_of_ctype ict) loc; iargs = []; permission = IT.( - and_ - [ (uintptr_int_ 0 loc' %<= q) loc'; (q %< uintptr_int_ length loc') loc' ] - loc') + and_ [ (uintptr_int_ 0 loc %<= q) loc; (q %< uintptr_int_ length loc) loc ] loc) } @@ -161,7 +159,7 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O let index_permission = IT.subst su ret.permission in (match prove_or_model (LC.T index_permission) with | `True -> - let loc' = Cerb_location.other __FUNCTION__ in + let loc = Cerb_location.other __FUNCTION__ in let at_index = ( P { name = ret.name; @@ -170,21 +168,21 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O pointer_offset_ ( ret.pointer, mul_ - ( cast_ Memory.uintptr_bt ret.step loc', - cast_ Memory.uintptr_bt index loc' ) - loc' ) - loc'); + ( cast_ Memory.uintptr_bt ret.step loc, + cast_ Memory.uintptr_bt index loc ) + loc ) + loc); iargs = List.map (IT.subst su) ret.iargs }, - O (IT.map_get_ o index loc') ) + O (IT.map_get_ o index loc) ) in let ret_reduced = { ret with permission = IT.( and_ - [ ret.permission; ne__ (sym_ (fst ret.q, snd ret.q, loc')) index loc' ] - loc') + [ ret.permission; ne__ (sym_ (fst ret.q, snd ret.q, loc)) index loc ] + loc) } in (* tmsg "successfully extracted" (lazy (IT.pp index)); *) diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index cef51b9b0..1ef2fbdf4 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -122,7 +122,7 @@ module IndexTerms = struct let simp_comp_if_int a b loc = - if BaseTypes.equal (IT.basetype a) BaseTypes.Integer then + if BaseTypes.equal (IT.get_bt a) BaseTypes.Integer then simp_int_comp a b loc else (a, b) diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index ff7b32591..809d6f0d4 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -1,8 +1,7 @@ module SMT = Simple_smt -open IndexTerms -open BaseTypes +module IT = IndexTerms +open IT module LC = LogicalConstraints -open LogicalConstraints module Int_BT_Table = Map.Make (struct type t = int * BT.t @@ -478,7 +477,7 @@ end (** Translate a base type to SMT *) let rec translate_base_type = function - | Unit -> CN_Tuple.t [] + | BT.Unit -> CN_Tuple.t [] | Bool -> SMT.t_bool | Integer -> SMT.t_int | MemByte -> CN_MemByte.t @@ -507,11 +506,11 @@ let rec get_ivalue gs ctys bt sexp = and get_value gs ctys bt (sexp : SMT.sexp) = match bt with - | Unit -> Const Unit + | BT.Unit -> Const Unit | Bool -> Const (Bool (SMT.to_bool sexp)) | Integer -> Const (Z (SMT.to_z sexp)) | Bits (sign, n) -> - let signed = equal_sign sign Signed in + let signed = BT.(equal_sign sign Signed) in Const (Bits ((sign, n), SMT.to_bits n signed sexp)) | Real -> Const (Q (SMT.to_q sexp)) | MemByte -> @@ -706,7 +705,7 @@ let rec translate_term s iterm = in match IT.get_term iterm with | Const c -> translate_const s c - | Sym x -> translate_var s x (IT.basetype iterm) + | Sym x -> translate_var s x (IT.get_bt iterm) | Unop (op, e1) -> (match op with | BW_FFS_NoSMT -> @@ -733,20 +732,20 @@ let rec translate_term s iterm = loc) | Not -> SMT.bool_not (translate_term s e1) | Negate -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_neg (translate_term s e1) | BT.Integer | BT.Real -> SMT.num_neg (translate_term s e1) | _ -> failwith (__FUNCTION__ ^ ":Unop (Negate, _)")) | BW_Compl -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_compl (translate_term s e1) | _ -> failwith (__FUNCTION__ ^ ":Unop (BW_Compl, _)")) | BW_CLZ_NoSMT -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_clz w w) | _ -> failwith "solver: BW_CLZ_NoSMT: not a bitwise type") | BW_CTZ_NoSMT -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_ctz w w) | _ -> failwith "solver: BW_CTZ_NoSMT: not a bitwise type")) | Binop (op, e1, e2) -> @@ -754,7 +753,7 @@ let rec translate_term s iterm = let s2 = translate_term s e2 in (* binary uninterpreted function, same type for arguments and result. *) let uninterp_same_type k = - let bt = IT.basetype iterm in + let bt = IT.get_bt iterm in let smt_t = translate_base_type bt in let f = declare_bt_uninterpreted s k bt [ smt_t; smt_t ] smt_t in SMT.app f [ s1; s2 ] @@ -764,23 +763,23 @@ let rec translate_term s iterm = | Or -> SMT.bool_or s1 s2 | Implies -> SMT.bool_implies s1 s2 | Add -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_add s1 s2 | BT.Integer | BT.Real -> SMT.num_add s1 s2 | _ -> failwith "Add") | Sub -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_sub s1 s2 | BT.Integer | BT.Real -> SMT.num_sub s1 s2 | _ -> failwith "Sub") | Mul -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_mul s1 s2 | BT.Integer | BT.Real -> SMT.num_mul s1 s2 | _ -> failwith "Mul") | MulNoSMT -> uninterp_same_type CN_Constant.mul | Div -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (BT.Signed, _) -> SMT.bv_sdiv s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_udiv s1 s2 | BT.Integer | BT.Real -> SMT.num_div s1 s2 @@ -793,50 +792,48 @@ let rec translate_term s iterm = | _, _ -> failwith "Exp") | ExpNoSMT -> uninterp_same_type CN_Constant.exp | Rem -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (BT.Signed, _) -> SMT.bv_srem s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 | BT.Integer -> SMT.num_rem s1 s2 (* CVC5 ?? *) | _ -> failwith "Rem") | RemNoSMT -> uninterp_same_type CN_Constant.rem | Mod -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (BT.Signed, _) -> SMT.bv_smod s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 | BT.Integer -> SMT.num_mod s1 s2 | _ -> failwith "Mod") | ModNoSMT -> uninterp_same_type CN_Constant.mod' | BW_Xor -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_xor s1 s2 | _ -> failwith "BW_Xor") | BW_And -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_and s1 s2 | _ -> failwith "BW_And") | BW_Or -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_or s1 s2 - | _ -> failwith "BW_Or") + (match IT.get_bt iterm with BT.Bits _ -> SMT.bv_or s1 s2 | _ -> failwith "BW_Or") (* Shift amount should be positive? *) | ShiftLeft -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_shl s1 s2 | _ -> failwith "ShiftLeft") (* Amount should be positive? *) | ShiftRight -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (BT.Signed, _) -> SMT.bv_ashr s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_lshr s1 s2 | _ -> failwith "ShiftRight") | LT -> - (match IT.basetype e1 with + (match IT.get_bt e1 with | BT.Bits (BT.Signed, _) -> SMT.bv_slt s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_ult s1 s2 | BT.Integer | BT.Real -> SMT.num_lt s1 s2 | _ -> failwith "LT") | LE -> - (match IT.basetype e1 with + (match IT.get_bt e1 with | BT.Bits (BT.Signed, _) -> SMT.bv_sleq s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_uleq s1 s2 | BT.Integer | BT.Real -> SMT.num_leq s1 s2 @@ -877,7 +874,7 @@ let rec translate_term s iterm = (* Tuples *) | Tuple es -> CN_Tuple.con (List.map (translate_term s) es) | NthTuple (n, e1) -> - (match IT.basetype e1 with + (match IT.get_bt e1 with | Tuple ts -> CN_Tuple.get (List.length ts) n (translate_term s e1) | _ -> failwith "NthTuple: not a tuple") (* Structs *) @@ -890,7 +887,7 @@ let rec translate_term s iterm = SMT.app_ (CN_Names.struct_field_name f) [ translate_term s e1 ] | StructUpdate ((t, member), v) -> let tag = BT.struct_bt (IT.get_bt t) in - let layout = Sym.Map.find (struct_bt (IT.get_bt t)) struct_decls in + let layout = Sym.Map.find (BT.struct_bt (IT.get_bt t)) struct_decls in let members = Memory.member_types layout in let str = List.map @@ -908,13 +905,13 @@ let rec translate_term s iterm = | OffsetOf (tag, member) -> let decl = Sym.Map.find tag struct_decls in let v = Option.get (Memory.member_offset decl member) in - translate_term s (int_lit_ v (IT.basetype iterm) loc) + translate_term s (int_lit_ v (IT.get_bt iterm) loc) (* Records *) | Record members -> let field (_, e) = translate_term s e in CN_Tuple.con (List.map field members) | RecordMember (e1, f) -> - (match IT.basetype e1 with + (match IT.get_bt e1 with | Record members -> let check (x, _) = Id.equal f x in let arity = List.length members in @@ -967,26 +964,26 @@ let rec translate_term s iterm = | Cons (e1, e2) -> CN_List.cons (translate_term s e1) (translate_term s e2) | Head e1 -> maybe_name (translate_term s e1) (fun xs -> - CN_List.head xs (translate_term s (default_ (IT.basetype iterm) loc))) + CN_List.head xs (translate_term s (default_ (IT.get_bt iterm) loc))) | Tail e1 -> maybe_name (translate_term s e1) (fun xs -> - CN_List.tail xs (translate_term s (default_ (IT.basetype iterm) loc))) + CN_List.tail xs (translate_term s (default_ (IT.get_bt iterm) loc))) | NthList (x, y, z) -> - let arg x = (translate_base_type (IT.basetype x), translate_term s x) in + let arg x = (translate_base_type (IT.get_bt x), translate_term s x) in let arg_ts, args = List.split (List.map arg [ x; y; z ]) in - let bt = IT.basetype iterm in + let bt = IT.get_bt iterm in let res_t = translate_base_type bt in let f = declare_bt_uninterpreted s CN_Constant.nth_list bt arg_ts res_t in SMT.app f args | ArrayToList (x, y, z) -> - let arg x = (translate_base_type (IT.basetype x), translate_term s x) in + let arg x = (translate_base_type (IT.get_bt x), translate_term s x) in let arg_ts, args = List.split (List.map arg [ x; y; z ]) in - let bt = IT.basetype iterm in + let bt = IT.get_bt iterm in let res_t = translate_base_type bt in let f = declare_bt_uninterpreted s CN_Constant.array_to_list bt arg_ts res_t in SMT.app f args | SizeOf ct -> - translate_term s (IT.int_lit_ (Memory.size_of_ctype ct) (IT.basetype iterm) loc) + translate_term s (IT.int_lit_ (Memory.size_of_ctype ct) (IT.get_bt iterm) loc) | Representable (ct, t) -> translate_term s (representable struct_decls ct t loc) | Good (ct, t) -> translate_term s (good_value struct_decls ct t loc) | Aligned t -> @@ -996,7 +993,7 @@ let rec translate_term s iterm = (* Maps *) | MapConst (bt, e1) -> let kt = translate_base_type bt in - let vt = translate_base_type (IT.basetype e1) in + let vt = translate_base_type (IT.get_bt e1) in SMT.arr_const kt vt (translate_term s e1) | MapSet (mp, k, v) -> SMT.arr_store (translate_term s mp) (translate_term s k) (translate_term s v) @@ -1007,7 +1004,7 @@ let rec translate_term s iterm = (match def.body with | Def body -> translate_term s (Definition.Function.open_ def.args body args) | _ -> - let do_arg arg = translate_base_type (IT.basetype arg) in + let do_arg arg = translate_base_type (IT.get_bt arg) in let args_ts = List.map do_arg args in let res_t = translate_base_type def.return_bt in let fu = declare_uninterpreted s name args_ts res_t in @@ -1043,7 +1040,7 @@ let rec translate_term s iterm = in let rec do_alts v alts = match alts with - | [] -> translate_term s (default_ (IT.basetype iterm) loc) + | [] -> translate_term s (default_ (IT.get_bt iterm) loc) | (pat, rhs) :: more -> let mb_cond, binds = match_pat v pat in let k = SMT.let_ binds (translate_term s rhs) in @@ -1097,7 +1094,7 @@ let rec translate_term s iterm = let add_assumption solver global lc = let s1 = { solver with globals = global } in match lc with - | T it -> ack_command solver (SMT.assume (translate_term s1 it)) + | LC.T it -> ack_command solver (SMT.assume (translate_term s1 it)) | Forall _ -> () @@ -1112,7 +1109,7 @@ let translate_goal solver assumptions lc = let here = Locations.other __FUNCTION__ in let instantiated = match lc with - | T it -> { expr = translate_term solver it; qs = []; extra = [] } + | LC.T it -> { expr = translate_term solver it; qs = []; extra = [] } | Forall ((s, bt), it) -> let v_s, v = IT.fresh_same bt s here in let it = IT.subst (make_subst [ (s, v) ]) it in @@ -1122,7 +1119,7 @@ let translate_goal solver assumptions lc = let v = sym_ (s, bt, here) in let check_asmp lc acc = match lc with - | Forall ((s', bt'), it') when BT.equal bt bt' -> + | LC.Forall ((s', bt'), it') when BT.equal bt bt' -> let new_asmp = IT.subst (make_subst [ (s', v) ]) it' in translate_term solver new_asmp :: acc | _ -> acc @@ -1166,7 +1163,7 @@ let rec declare_struct s done_struct name decl = let mk_field (l, t) = let rec declare_nested ty = match ty with - | Struct name' -> + | BT.Struct name' -> let decl = Sym.Map.find name' s.globals.struct_decls in declare_struct s done_struct name' decl | Map (_, el) -> declare_nested el @@ -1373,7 +1370,7 @@ let model_evaluator = | SMT.Sat -> let res = SMT.get_expr smt_solver inp in let ctys = get_ctype_table evaluator in - Some (get_ivalue gs ctys (basetype e) (SMT.no_let res)) + Some (get_ivalue gs ctys (get_bt e) (SMT.no_let res)) | _ -> None in Hashtbl.add models_tbl model_id model_fn; From 77975378d4bab3d52ccf2f6ba13e0bb13033891e Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 25 Dec 2024 15:24:06 +0000 Subject: [PATCH 123/148] CN: Tidy up Id and LogicalCosntraints module This makes the new location in making identifiers explicit. --- backend/cn/lib/alloc.ml | 6 +- backend/cn/lib/argumentTypes.ml | 3 +- backend/cn/lib/check.ml | 2 +- backend/cn/lib/cn_internal_to_ail.ml | 67 ++++++++++++--------- backend/cn/lib/compile.ml | 20 +++--- backend/cn/lib/core_to_mucore.ml | 3 +- backend/cn/lib/definition.mli | 2 +- backend/cn/lib/id.ml | 19 ++---- backend/cn/lib/id.mli | 19 ++---- backend/cn/lib/indexTerms.ml | 12 ++-- backend/cn/lib/lemmata.ml | 23 +++---- backend/cn/lib/logicalArgumentTypes.ml | 5 +- backend/cn/lib/logicalConstraints.ml | 15 ++--- backend/cn/lib/logicalConstraints.mli | 39 ++++++++++++ backend/cn/lib/logicalReturnTypes.ml | 5 +- backend/cn/lib/pack.ml | 2 +- backend/cn/lib/resourceInference.mli | 2 +- backend/cn/lib/returnTypes.ml | 3 +- backend/cn/lib/solver.ml | 4 +- backend/cn/lib/testGeneration/genCodeGen.ml | 5 +- backend/cn/lib/testGeneration/genCompile.ml | 13 ++-- backend/cn/lib/wellTyped.ml | 4 +- 22 files changed, 159 insertions(+), 114 deletions(-) create mode 100644 backend/cn/lib/logicalConstraints.mli diff --git a/backend/cn/lib/alloc.ml b/backend/cn/lib/alloc.ml index d4241ecbe..a65282a34 100644 --- a/backend/cn/lib/alloc.ml +++ b/backend/cn/lib/alloc.ml @@ -3,11 +3,13 @@ module History = struct let sym = Sym.fresh_named str - let base_id = Id.id "base" + let here = Locations.other __FUNCTION__ + + let base_id = Id.make here "base" let base_bt = Memory.uintptr_bt - let size_id = Id.id "size" + let size_id = Id.make here "size" let size_bt = Memory.uintptr_bt diff --git a/backend/cn/lib/argumentTypes.ml b/backend/cn/lib/argumentTypes.ml index 575bcbb61..55b97f2e1 100644 --- a/backend/cn/lib/argumentTypes.ml +++ b/backend/cn/lib/argumentTypes.ml @@ -91,7 +91,8 @@ let binders i_binders i_subst = let rec aux = function | Computational ((s, bt), _, t) -> let s, t = alpha_rename i_subst s t in - (Id.id (Sym.pp_string s), bt) :: aux t + let here = Locations.other __FUNCTION__ in + (Id.make here (Sym.pp_string s), bt) :: aux t | L t -> LAT.binders i_binders i_subst t in aux diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index c77a261c8..a05f28c51 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -1935,7 +1935,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ it = WellTyped.WIT.infer it in let@ original_rs, _ = all_resources_tagged loc in (* let verbose = List.exists (Id.is_str "verbose") attrs in *) - let quiet = List.exists (Id.is_str "quiet") attrs in + let quiet = List.exists (Id.equal_string "quiet") attrs in let@ () = add_movable_index loc (predicate_name, it) in let@ upd_rs, _ = all_resources_tagged loc in if diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 7db0b5291..79a0ae08e 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -52,7 +52,7 @@ module MembersKey = struct | _, [] -> 1 | [], _ -> -1 | (id, bt) :: ms, (id', bt') :: ms' -> - let c = String.compare (Id.s id) (Id.s id') in + let c = String.compare (Id.get_string id) (Id.get_string id') in if c == 0 then ( let c' = BaseTypes.compare bt bt' in if c' == 0 then @@ -72,10 +72,11 @@ let generic_cn_dt_sym = Sym.fresh_pretty "cn_datatype" let create_id_from_sym ?(lowercase = false) sym = let str = Sym.pp_string sym in let str = if lowercase then String.lowercase_ascii str else str in - Id.id str + let here = Locations.other __FUNCTION__ in + Id.make here str -let create_sym_from_id id = Sym.fresh_pretty (Id.pp_string id) +let create_sym_from_id id = Sym.fresh_pretty (Id.get_string id) let generate_sym_with_suffix ?(suffix = "_tag") @@ -677,13 +678,15 @@ let generate_get_or_put_ownership_function ~without_ownership_checking ctype let ctype_str = String.concat "_" (String.split_on_char ' ' ctype_str) in let fn_sym = Sym.fresh_pretty ("owned_" ^ ctype_str) in let param1_sym = Sym.fresh_pretty "cn_ptr" in + let here = Locations.other __FUNCTION__ in let cast_expr = mk_expr A.( AilEcast ( empty_qualifiers, mk_ctype C.(Pointer (empty_qualifiers, ctype)), - mk_expr (AilEmemberofptr (mk_expr (AilEident param1_sym), Id.id "ptr")) )) + mk_expr (AilEmemberofptr (mk_expr (AilEident param1_sym), Id.make here "ptr")) + )) in let generic_c_ptr_sym = Sym.fresh_pretty "generic_c_ptr" in let generic_c_ptr_bs, generic_c_ptr_ss = @@ -1094,14 +1097,15 @@ let rec cn_to_ail_expr_aux_internal in let ail_decl = A.(AilSdeclaration [ (res_sym, Some (mk_expr fn_call)) ]) in let lc_constr_sym = generate_sym_with_suffix ~suffix:"" ~lowercase:true sym in - let e_ = A.(AilEmemberofptr (mk_expr res_ident, Id.id "u")) in + let here = Locations.other __FUNCTION__ in + let e_ = A.(AilEmemberofptr (mk_expr res_ident, Id.make here "u")) in let e_' = A.(AilEmemberof (mk_expr e_, create_id_from_sym lc_constr_sym)) in let generate_ail_stat (id, it) = let b, s, e = cn_to_ail_expr_aux_internal const_prop pred_name dts globals it PassBack in let ail_memberof = - if Id.equal id (Id.id "tag") then + if Id.equal id (Id.make here "tag") then e else ( let e_'' = A.(AilEmemberofptr (mk_expr e_', id)) in @@ -1130,7 +1134,7 @@ let rec cn_to_ail_expr_aux_internal in let bs, ss, assign_stats = list_split_three (List.map generate_ail_stat ms) in let uc_constr_sym = generate_sym_with_suffix ~suffix:"" ~uppercase:true sym in - let tag_member_ptr = A.(AilEmemberofptr (mk_expr res_ident, Id.id "tag")) in + let tag_member_ptr = A.(AilEmemberofptr (mk_expr res_ident, Id.make here "tag")) in let tag_assign = A.( AilSexpr @@ -1315,7 +1319,8 @@ let rec cn_to_ail_expr_aux_internal | _ :: _ -> failwith "Non-sum pattern" | [] -> assert false in - let transform_switch_expr e = A.(AilEmemberofptr (e, Id.id "tag")) in + let here = Locations.other __FUNCTION__ in + let transform_switch_expr e = A.(AilEmemberofptr (e, Id.make here "tag")) in (* Matrix algorithm for pattern compilation *) let rec translate : int -> IT.t list -> (BT.t IT.pattern list * IT.t) list -> Sym.sym option -> @@ -1374,7 +1379,7 @@ let rec cn_to_ail_expr_aux_internal let count_sym = generate_sym_with_suffix ~suffix ~lowercase:true constr_sym in - let rhs_memberof_ptr = A.(AilEmemberofptr (e1, Id.id "u")) in + let rhs_memberof_ptr = A.(AilEmemberofptr (e1, Id.make here "u")) in (* TODO: Remove hack *) let rhs_memberof = A.(AilEmemberof (mk_expr rhs_memberof_ptr, create_id_from_sym lc_sym)) @@ -1569,7 +1574,8 @@ let generate_map_get sym = let ret_sym = Sym.fresh_pretty "ret" in let ret_binding = create_binding ret_sym void_ptr_type in let key_val_mem = - mk_expr A.(AilEmemberofptr (mk_expr (AilEident param2_sym), Id.id "val")) + let here = Locations.other __FUNCTION__ in + mk_expr A.(AilEmemberofptr (mk_expr (AilEident param2_sym), Id.make here "val")) in let ht_get_fcall = mk_expr @@ -1629,15 +1635,16 @@ let cn_to_ail_datatype ?(first = false) (cn_datatype : cn_datatype) = let enum_sym = generate_sym_with_suffix cn_datatype.cn_dt_name in let constructor_syms = List.map fst cn_datatype.cn_dt_cases in + let here = Locations.other __FUNCTION__ in let generate_enum_member sym = let doc = CF.Pp_ail.pp_id sym in let str = CF.Pp_utils.to_plain_string doc in let str = String.uppercase_ascii str in - Id.id str + Id.make here str in let enum_member_syms = List.map generate_enum_member constructor_syms in let attr : CF.Annot.attribute = - { attr_ns = None; attr_id = Id.id "enum"; attr_args = [] } + { attr_ns = None; attr_id = Id.make here "enum"; attr_args = [] } in let attrs = CF.Annot.Attrs [ attr ] in let enum_members = @@ -1650,8 +1657,8 @@ let cn_to_ail_datatype ?(first = false) (cn_datatype : cn_datatype) let cntype_sym = Sym.fresh_pretty "cntype" in let cntype_pointer = C.(Pointer (empty_qualifiers, mk_ctype (Struct cntype_sym))) in let extra_members tag_type = - [ create_member (mk_ctype tag_type, Id.id "tag"); - create_member (mk_ctype cntype_pointer, Id.id "cntype") + [ create_member (mk_ctype tag_type, Id.make here "tag"); + create_member (mk_ctype cntype_pointer, Id.make here "cntype") ] in let bt_cases = @@ -1687,7 +1694,7 @@ let cn_to_ail_datatype ?(first = false) (cn_datatype : cn_datatype) constructor_syms in let union_def = C.(UnionDef union_def_members) in - let union_member = create_member (mk_ctype C.(Union union_sym), Id.id "u") in + let union_member = create_member (mk_ctype C.(Union union_sym), Id.make here "u") in let structs = structs @ [ (union_sym, (Cerb_location.unknown, empty_attributes, union_def)); @@ -1717,7 +1724,8 @@ let generate_datatype_equality_function (cn_datatype : cn_datatype) let fn_sym = Sym.fresh_pretty ("struct_" ^ Sym.pp_string dt_sym ^ "_equality") in let param1_sym = Sym.fresh_pretty "x" in let param2_sym = Sym.fresh_pretty "y" in - let id_tag = Id.id "tag" in + let here = Locations.other __FUNCTION__ in + let id_tag = Id.make here "tag" in let param_syms = [ param1_sym; param2_sym ] in let param_type = ( empty_qualifiers, @@ -1782,7 +1790,8 @@ let generate_datatype_equality_function (cn_datatype : cn_datatype) in let memberof_ptr_es = List.map - (fun sym -> mk_expr A.(AilEmemberofptr (mk_expr (AilEident sym), Id.id "u"))) + (fun sym -> + mk_expr A.(AilEmemberofptr (mk_expr (AilEident sym), Id.make here "u"))) param_syms in let decls = @@ -1892,11 +1901,13 @@ let generate_datatype_default_function (cn_datatype : cn_datatype) = } in let enum_ident = mk_expr A.(AilEident enum_sym) in + let here = Locations.other __FUNCTION__ in let res_tag_assign = A.( AilSexpr (mk_expr - (AilEassign (mk_expr (AilEmemberofptr (res_ident, Id.id "tag")), enum_ident)))) + (AilEassign + (mk_expr (AilEmemberofptr (res_ident, Id.make here "tag")), enum_ident)))) in let res_tag_assign_stat = A.( @@ -1904,7 +1915,7 @@ let generate_datatype_default_function (cn_datatype : cn_datatype) = (Cerb_location.unknown, CF.Annot.Attrs [ attribute ], res_tag_assign)) in let lc_constr_sym = generate_sym_with_suffix ~suffix:"" ~lowercase:true constructor in - let res_u = A.(AilEmemberofptr (res_ident, Id.id "u")) in + let res_u = A.(AilEmemberofptr (res_ident, Id.make here "u")) in let res_u_constr = mk_expr (AilEmemberof (mk_expr res_u, create_id_from_sym lc_constr_sym)) in @@ -2418,7 +2429,7 @@ let generate_record_default_function _dts (sym, (members : BT.member_types)) let ret_ident = A.(AilEident ret_sym) in (* Function body *) let generate_member_default_assign (id, bt) = - (* Printf.printf "Member: %s\n" (Id.pp_string id); *) + (* Printf.printf "Member: %s\n" (Id.get_string id); *) let lhs = A.(AilEmemberofptr (mk_expr ret_ident, id)) in let member_ctype_str_opt = get_underscored_typedef_string_from_bt bt in let default_fun_str = @@ -2840,16 +2851,12 @@ let cn_to_ail_resource_internal let cn_to_ail_logical_constraint_internal : type a. - _ CF.Cn.cn_datatype list -> - (C.union_tag * C.ctype) list -> - a dest -> - LC.logical_constraint -> - a + _ CF.Cn.cn_datatype list -> (C.union_tag * C.ctype) list -> a dest -> LC.t -> a = fun dts globals d lc -> match lc with - | LogicalConstraints.T it -> cn_to_ail_expr_internal dts globals it d - | LogicalConstraints.Forall ((sym, bt), it) -> + | LC.T it -> cn_to_ail_expr_internal dts globals it d + | LC.Forall ((sym, bt), it) -> let cond_it, t = match IT.get_term it with | Binop (Implies, it, it') -> (it, it') @@ -3461,13 +3468,15 @@ let generate_assume_ownership_function ~without_ownership_checking ctype let ctype_str = String.concat "_" (String.split_on_char ' ' ctype_str) in let fn_sym = Sym.fresh_pretty ("assume_owned_" ^ ctype_str) in let param1_sym = Sym.fresh_pretty "cn_ptr" in + let here = Locations.other __FUNCTION__ in let cast_expr = mk_expr A.( AilEcast ( empty_qualifiers, mk_ctype C.(Pointer (empty_qualifiers, ctype)), - mk_expr (AilEmemberofptr (mk_expr (AilEident param1_sym), Id.id "ptr")) )) + mk_expr (AilEmemberofptr (mk_expr (AilEident param1_sym), Id.make here "ptr")) + )) in let param2_sym = Sym.fresh_pretty "fun" in let param1 = (param1_sym, bt_to_ail_ctype BT.(Loc ())) in @@ -3481,7 +3490,7 @@ let generate_assume_ownership_function ~without_ownership_checking ctype let ownership_fn_sym = Sym.fresh_pretty "cn_assume_ownership" in let ownership_fn_args = A. - [ AilEmemberofptr (mk_expr (AilEident param1_sym), Id.id "ptr"); + [ AilEmemberofptr (mk_expr (AilEident param1_sym), Id.make here "ptr"); AilEsizeof (empty_qualifiers, ctype); AilEident param2_sym ] diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index b00e2c4d7..1875f0f4a 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -334,12 +334,16 @@ let add_datatype_info env (dt : cn_datatype) = (* SMT format constraints seem to require variables to be unique to the datatype, not just the constructor. *) let add_param m (nm, ty) = - match StringMap.find_opt (Id.s nm) m with + match StringMap.find_opt (Id.get_string nm) m with | None -> - return (StringMap.add (Id.s nm) (nm, SBT.proj (translate_cn_base_type env ty)) m) + return + (StringMap.add + (Id.get_string nm) + (nm, SBT.proj (translate_cn_base_type env ty)) + m) | Some _ -> fail - { loc = Id.loc nm; + { loc = Id.get_loc nm; msg = Generic (!^"Re-using member name" @@ -689,7 +693,7 @@ module EffectfulTranslation = struct ListM.fold_rightM (fun (id, v) expr -> let@ v = self v in - let start_pos = Option.get @@ Locations.start_pos @@ Id.loc id in + let start_pos = Option.get @@ Locations.start_pos @@ Id.get_loc id in let cursor = Cerb_location.PointCursor start_pos in let loc = Locations.region (start_pos, end_pos) cursor in return (IT (StructUpdate ((expr, id), v), bt, loc))) @@ -1203,14 +1207,16 @@ let translate_cn_function env (def : cn_function) = List.map (fun (sym, bTy) -> (sym, translate_cn_base_type env bTy)) def.cn_func_args in let env' = List.fold_left (fun acc (sym, bt) -> add_logical sym bt acc) env args in - let is_rec = List.exists (fun id -> String.equal (Id.s id) "rec") def.cn_func_attrs in + let is_rec = + List.exists (fun id -> String.equal (Id.get_string id) "rec") def.cn_func_attrs + in let coq_unfold = - List.exists (fun id -> String.equal (Id.s id) "coq_unfold") def.cn_func_attrs + List.exists (fun id -> String.equal (Id.get_string id) "coq_unfold") def.cn_func_attrs in let@ () = ListM.iterM (fun id -> - if List.exists (String.equal (Id.s id)) known_attrs then + if List.exists (String.equal (Id.get_string id)) known_attrs then return () else fail diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 846554ddf..4b85fe428 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -1263,7 +1263,8 @@ let normalise_fun_map_decl let@ accesses = ListM.mapM (desugar_access d_st global_types) accesses in let@ requires, d_st = desugar_conds d_st (List.map snd requires) in debug 6 (lazy (string "desugared requires conds")); - let@ ret_s, ret_d_st = register_new_cn_local (Id.id "return") d_st in + let here = Locations.other __LOC__ in + let@ ret_s, ret_d_st = register_new_cn_local (Id.make here "return") d_st in let@ ensures, _ret_d_st = desugar_conds ret_d_st (List.map snd ensures) in debug 6 (lazy (string "desugared ensures conds")); let@ spec_req, spec_ens, env = diff --git a/backend/cn/lib/definition.mli b/backend/cn/lib/definition.mli index fd30bd323..e2f0f0bd4 100644 --- a/backend/cn/lib/definition.mli +++ b/backend/cn/lib/definition.mli @@ -61,7 +61,7 @@ module Predicate : sig val instantiate : t -> IndexTerms.t -> IndexTerms.t list -> Clause.t list option val identify_right_clause - : (LogicalConstraints.logical_constraint -> [< `False | `True ]) -> + : (LogicalConstraints.t -> [< `False | `True ]) -> t -> IndexTerms.t -> IndexTerms.t list -> diff --git a/backend/cn/lib/id.ml b/backend/cn/lib/id.ml index 10b7587fc..f11e000b8 100644 --- a/backend/cn/lib/id.ml +++ b/backend/cn/lib/id.ml @@ -2,25 +2,18 @@ module CF = Cerb_frontend type t = CF.Symbol.identifier -let s (CF.Symbol.Identifier (_, s)) = s +let get_string (CF.Symbol.Identifier (_, s)) = s -let loc (CF.Symbol.Identifier (loc, _)) = loc +let get_loc (CF.Symbol.Identifier (loc, _)) = loc -let pp_string id = s id - -let pp id = PPrint.( !^ ) (s id) +let pp id = PPrint.( !^ ) (get_string id) let equal = CF.Symbol.idEqual -let compare id id' = String.compare (s id) (s id') - -let parse loc id = CF.Symbol.Identifier (loc, id) - -let id id = - let here = Locations.other __FUNCTION__ in - CF.Symbol.Identifier (here, id) +let compare id id' = String.compare (get_string id) (get_string id') +let make loc id = CF.Symbol.Identifier (loc, id) -let is_str str id = String.equal (s id) str +let equal_string str id = String.equal (get_string id) str let subst _ id = id diff --git a/backend/cn/lib/id.mli b/backend/cn/lib/id.mli index 5c3edccb6..a903acf30 100644 --- a/backend/cn/lib/id.mli +++ b/backend/cn/lib/id.mli @@ -3,20 +3,11 @@ This module adds a number of useful functions on identifiers to the ones already provided by Cerberus. *) -(* TODO: BCP: I'm a bit surprised that some of these are not already provided by - Cerberus! *) -(* TODO: DCM: Id.s should IMO be to_string Id.pp_string should be deleted or deprecated - Id.parse would be clearer as Id.make Id.id should really be deprecated/deleted since - the location info is not useful unless used at the call site. Id.is_str can maybe stay - as is or be renamed to Id.equal_string *) - type t = Cerb_frontend.Symbol.identifier -val s : t -> string - -val loc : t -> Cerb_location.t +val get_string : t -> string -val pp_string : t -> string +val get_loc : t -> Cerb_location.t val pp : t -> PPrint.document @@ -24,10 +15,8 @@ val equal : t -> t -> bool val compare : t -> t -> int -val parse : Cerb_location.t -> string -> t - -val id : string -> t +val make : Cerb_location.t -> string -> t -val is_str : String.t -> t -> bool +val equal_string : String.t -> t -> bool val subst : 'a -> 'b -> 'b diff --git a/backend/cn/lib/indexTerms.ml b/backend/cn/lib/indexTerms.ml index 731b4c0ae..e0371568b 100644 --- a/backend/cn/lib/indexTerms.ml +++ b/backend/cn/lib/indexTerms.ml @@ -15,11 +15,11 @@ module Surface = struct type t = BaseTypes.Surface.t annot - let compare = Terms.compare_annot BaseTypes.Surface.compare + let compare = compare_annot BaseTypes.Surface.compare - let proj = Terms.map_annot BaseTypes.Surface.proj + let proj = map_annot BaseTypes.Surface.proj - let inj x = Terms.map_annot BaseTypes.Surface.inj x + let inj x = map_annot BaseTypes.Surface.inj x end let get_bt : 'a. 'a annot -> 'a = function IT (_, bt, _) -> bt @@ -28,7 +28,7 @@ let get_term (IT (t, _, _)) = t let get_loc (IT (_, _, l)) = l -let pp ?(prec = 0) = Terms.pp ~prec +let pp ?(prec = 0) = pp ~prec let pp_with_typf f it = Pp.typ (pp it) (f (get_bt it)) @@ -140,7 +140,7 @@ let free_vars (it : 'a annot) : Sym.Set.t = it |> free_vars_bts |> Sym.Map.bindings |> List.map fst |> Sym.Set.of_list -let free_vars_ (t_ : 'a Terms.term) : Sym.Set.t = +let free_vars_ (t_ : 'a term) : Sym.Set.t = IT (t_, Unit, Locations.other "") |> free_vars_bts |> Sym.Map.bindings @@ -688,7 +688,7 @@ let ( %. ) struct_decls t member = | Some sct -> Memory.bt_of_sct sct | None -> Cerb_debug.error - ("struct " ^ Sym.pp_string tag ^ " does not have member " ^ Id.pp_string member) + ("struct " ^ Sym.pp_string tag ^ " does not have member " ^ Id.get_string member) in member_ ~member_bt (t, member) diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index 8d18d8ce1..8b840648f 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -298,8 +298,9 @@ let add_list_mono_datatype (bt, nm) global = let bt_name = Sym.pp_string (Option.get (BT.is_datatype_bt bt)) in let nil = Sym.fresh_named ("Nil_of_" ^ bt_name) in let cons = Sym.fresh_named ("Cons_of_" ^ bt_name) in - let hd = Id.id ("hd_of_" ^ bt_name) in - let tl = Id.id ("tl_of_" ^ bt_name) in + let here = Locations.other __LOC__ in + let hd = Id.make here ("hd_of_" ^ bt_name) in + let tl = Id.make here ("tl_of_" ^ bt_name) in let mems = [ (hd, bt); (tl, BT.Datatype nm) ] in let datatypes = Sym.Map.add nm Dt.{ constrs = [ nil; cons ]; all_params = mems } global.datatypes @@ -634,7 +635,7 @@ and ensure_datatype (global : Global.t) (list_mono : list_mono) loc dt_tag = let ensure_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let@ () = ensure_datatype global list_mono loc dt_tag in - let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.pp_string mem_tag in + let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.get_string mem_tag in let dt_info = Sym.Map.find dt_tag global.Global.datatypes in let inf = (loc, Pp.typ (Pp.string "datatype acc for") (Sym.pp dt_tag)) in let@ bt_doc = bt_to_coq global list_mono inf bt in @@ -662,7 +663,7 @@ let ensure_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let@ () = gen_ensure 0 - [ "types"; "datatype acc"; Sym.pp_string dt_tag; Id.pp_string mem_tag ] + [ "types"; "datatype acc"; Sym.pp_string dt_tag; Id.get_string mem_tag ] (lazy (let open Pp in let eline = [ !^" end" ] in @@ -681,7 +682,7 @@ let ensure_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let ensure_single_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let@ () = ensure_datatype global list_mono loc dt_tag in - let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.pp_string mem_tag in + let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.get_string mem_tag in let dt_info = Sym.Map.find dt_tag global.Global.datatypes in let cons_line c = let c_info = Sym.Map.find c global.Global.datatype_constrs in @@ -700,7 +701,7 @@ let ensure_single_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) b let@ () = gen_ensure 0 - [ "types"; "datatype acc"; Sym.pp_string dt_tag; Id.pp_string mem_tag ] + [ "types"; "datatype acc"; Sym.pp_string dt_tag; Id.get_string mem_tag ] (lazy (let inf = (loc, Pp.typ (Pp.string "datatype acc for") (Sym.pp dt_tag)) in let@ bt_doc = bt_to_coq global list_mono inf bt in @@ -869,7 +870,7 @@ let mk_forall global list_mono loc sym bt doc = let add_dt_param_counted (it, (m_nm : Id.t)) = let@ st = get in let idx = List.length st.dt_params in - let sym = Sym.fresh_named (Id.pp_string m_nm ^ "_" ^ Int.to_string idx) in + let sym = Sym.fresh_named (Id.get_string m_nm ^ "_" ^ Int.to_string idx) in let@ () = add_dt_param (it, m_nm, sym) in return sym @@ -1036,7 +1037,7 @@ let it_to_coq loc global list_mono it = aux t else ( let ix = find_tuple_element Id.equal m Id.pp (List.map fst flds) in - let@ op_nm = ensure_tuple_op false (Id.pp_string m) ix in + let@ op_nm = ensure_tuple_op false (Id.get_string m) ix in parensM (build [ rets op_nm; aux t ])) | IT.RecordUpdate ((t, m), x) -> let flds = BT.record_bt (IT.get_bt t) in @@ -1044,7 +1045,7 @@ let it_to_coq loc global list_mono it = aux x else ( let ix = find_tuple_element Id.equal m Id.pp (List.map fst flds) in - let@ op_nm = ensure_tuple_op true (Id.pp_string m) ix in + let@ op_nm = ensure_tuple_op true (Id.get_string m) ix in parensM (build [ rets op_nm; aux t; aux x ])) | IT.Record mems -> let@ xs = ListM.mapM aux (List.map snd mems) in @@ -1056,7 +1057,7 @@ let it_to_coq loc global list_mono it = if List.length mems == 1 then aux t else - let@ op_nm = ensure_tuple_op false (Id.pp_string m) ix in + let@ op_nm = ensure_tuple_op false (Id.get_string m) ix in parensM (build [ rets op_nm; aux t ]) | IT.StructUpdate ((t, m), x) -> let tag = BaseTypes.struct_bt (IT.get_bt t) in @@ -1065,7 +1066,7 @@ let it_to_coq loc global list_mono it = if List.length mems == 1 then aux x else - let@ op_nm = ensure_tuple_op true (Id.pp_string m) ix in + let@ op_nm = ensure_tuple_op true (Id.get_string m) ix in parensM (build [ rets op_nm; aux t; aux x ]) | IT.Cast (cbt, t) -> (match (IT.get_bt t, cbt) with diff --git a/backend/cn/lib/logicalArgumentTypes.ml b/backend/cn/lib/logicalArgumentTypes.ml index 9282f1a36..c7bf56ac9 100644 --- a/backend/cn/lib/logicalArgumentTypes.ml +++ b/backend/cn/lib/logicalArgumentTypes.ml @@ -164,13 +164,14 @@ let alpha_unique ss = let binders i_binders i_subst = + let here = Locations.other __FUNCTION__ in let rec aux = function | Define ((s, it), _, t) -> let s, t = alpha_rename i_subst s t in - (Id.id (Sym.pp_string s), IT.get_bt it) :: aux t + (Id.make here (Sym.pp_string s), IT.get_bt it) :: aux t | Resource ((s, (_, bt)), _, t) -> let s, t = alpha_rename i_subst s t in - (Id.id (Sym.pp_string s), bt) :: aux t + (Id.make here (Sym.pp_string s), bt) :: aux t | Constraint (_, _, t) -> aux t | I i -> i_binders i in diff --git a/backend/cn/lib/logicalConstraints.ml b/backend/cn/lib/logicalConstraints.ml index c1444353b..6ab216949 100644 --- a/backend/cn/lib/logicalConstraints.ml +++ b/backend/cn/lib/logicalConstraints.ml @@ -2,21 +2,16 @@ module IT = IndexTerms module BT = BaseTypes open Pp -type logical_constraint = +type t = | T of IT.t | Forall of (Sym.t * BT.t) * IT.t [@@deriving eq, ord] -module Ord = struct - type t = logical_constraint +module Set = Set.Make (struct + type nonrec t = t - let equal = equal_logical_constraint - - let compare = compare_logical_constraint -end - -include Ord -module Set = Set.Make (Ord) + let compare = compare + end) let pp = function | T it -> IT.pp it diff --git a/backend/cn/lib/logicalConstraints.mli b/backend/cn/lib/logicalConstraints.mli new file mode 100644 index 000000000..671e0eb04 --- /dev/null +++ b/backend/cn/lib/logicalConstraints.mli @@ -0,0 +1,39 @@ +type t = + | T of IndexTerms.t + | Forall of (Sym.t * BaseTypes.t) * IndexTerms.t + +val equal : t -> t -> bool + +val compare : t -> t -> int + +module Set : Set.S with type elt = t + +val pp : t -> Pp.document + +val json : t -> Yojson.Safe.t + +val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t + +val subst_ : (Sym.t * IndexTerms.t) list -> t -> t + +val free_vars_bts : t -> BaseTypes.t Sym.Map.t + +val free_vars : t -> Sym.Set.t + +val alpha_equivalent : t -> t -> bool + +val forall_ : Sym.t * BaseTypes.t -> IndexTerms.t -> t + +val is_sym_lhs_equality : t -> (Sym.t * IndexTerms.t) option + +val is_sym_equality : t -> (Sym.t * Sym.t) option + +val is_equality : t -> ((IndexTerms.t * IndexTerms.t) * bool) option + +val equates_to : IndexTerms.t -> t -> IndexTerms.t option + +val dtree : t -> Cerb_frontend.Pp_ast.doc_tree + +val is_forall : t -> bool + +val is_interesting : t -> bool diff --git a/backend/cn/lib/logicalReturnTypes.ml b/backend/cn/lib/logicalReturnTypes.ml index 53a334e4d..b2165e170 100644 --- a/backend/cn/lib/logicalReturnTypes.ml +++ b/backend/cn/lib/logicalReturnTypes.ml @@ -84,13 +84,14 @@ let alpha_unique ss = let binders = + let here = Locations.other __FUNCTION__ in let rec aux = function | Define ((s, it), _, t) -> let s, t = alpha_rename s t in - (Id.id (Sym.pp_string s), IT.get_bt it) :: aux t + (Id.make here (Sym.pp_string s), IT.get_bt it) :: aux t | Resource ((s, (_, bt)), _, t) -> let s, t = alpha_rename s t in - (Id.id (Sym.pp_string s), bt) :: aux t + (Id.make here (Sym.pp_string s), bt) :: aux t | Constraint (_, _, t) -> aux t | I -> [] in diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index 9ae3b8e69..beba8b43f 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -62,7 +62,7 @@ let packing_ft loc global provable ret = } in let m_value_s, m_value = - IT.fresh_named (Memory.bt_of_sct mct) (Id.s member) loc + IT.fresh_named (Memory.bt_of_sct mct) (Id.get_string member) loc in ( LRT.Resource ((m_value_s, (request, IT.get_bt m_value)), (loc, None), lrt), (member, m_value) :: value ) diff --git a/backend/cn/lib/resourceInference.mli b/backend/cn/lib/resourceInference.mli index 5026e289e..e2ac6dba0 100644 --- a/backend/cn/lib/resourceInference.mli +++ b/backend/cn/lib/resourceInference.mli @@ -2,7 +2,7 @@ val debug_constraint_failure_diagnostics : int -> Solver.model_with_q -> Simplify.simp_ctxt -> - LogicalConstraints.logical_constraint -> + LogicalConstraints.t -> unit module General : sig diff --git a/backend/cn/lib/returnTypes.ml b/backend/cn/lib/returnTypes.ml index 967ba3adc..48fdf88ab 100644 --- a/backend/cn/lib/returnTypes.ml +++ b/backend/cn/lib/returnTypes.ml @@ -43,7 +43,8 @@ let simp simp_it simp_lc simp_re = function let binders = function | Computational ((s, bt), _, t) -> let s, t = LRT.alpha_rename s t in - (Id.id (Sym.pp_string s), bt) :: LRT.binders t + let here = Locations.other __FUNCTION__ in + (Id.make here (Sym.pp_string s), bt) :: LRT.binders t let map (f : LRT.t -> LRT.t) = function diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 809d6f0d4..653417ba3 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -35,13 +35,13 @@ module CN_Names = struct let struct_con_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let struct_field_name x = Id.pp_string x ^ "_struct_fld" + let struct_field_name x = Id.get_string x ^ "_struct_fld" let datatype_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) let datatype_con_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let datatype_field_name x = Id.pp_string x ^ "_data_fld" + let datatype_field_name x = Id.get_string x ^ "_data_fld" end (** Names for constants that may be uninterpreted. See [bt_uninterpreted] *) diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index cb4257083..808624e28 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -499,7 +499,7 @@ let compile_gen_def = let loc = Locations.other __LOC__ in let bt_ret = - BT.Record (List.map (fun (x, bt) -> (Id.id (Sym.pp_string x), bt)) gr.oargs) + BT.Record (List.map (fun (x, bt) -> (Id.make loc (Sym.pp_string x), bt)) gr.oargs) in let struct_def = CtA.generate_record_opt name bt_ret |> Option.get in let ct_ret = C.(mk_ctype_pointer no_qualifiers (Ctype ([], Struct (fst struct_def)))) in @@ -584,8 +584,9 @@ let compile (sigma : CF.GenTypes.genTypeCategory A.sigma) (ctx : GR.context) : P in defs |> List.iter (fun ((name, def) : Sym.t * GR.definition) -> + let loc = Locations.other __LOC__ in let bt = - BT.Record (List.map (fun (x, bt) -> (Id.id (Sym.pp_string x), bt)) def.oargs) + BT.Record (List.map (fun (x, bt) -> (Id.make loc (Sym.pp_string x), bt)) def.oargs) in CtA.augment_record_map ~cn_sym:name bt); let tag_definitions, funcs = List.split (List.map (compile_gen_def sigma ctx) defs) in diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index af9bc2932..87e84d250 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -130,7 +130,8 @@ let rec compile_it_lat -> let here = Locations.other __LOC__ in let ret_bt = - BT.Record (compile_oargs bt [] |> List.map_fst (fun x -> Id.id (Sym.pp_string x))) + BT.Record + (compile_oargs bt [] |> List.map_fst (fun x -> Id.make here (Sym.pp_string x))) in (* Recurse *) let@ gt' = @@ -223,9 +224,11 @@ let rec compile_it_lat (* Build [GT.t] *) let _, v_bt = BT.map_bt bt in let gt_body = + let here = Locations.other __LOC__ in let ret_bt = BT.Record - (compile_oargs v_bt [] |> List.map_fst (fun x -> Id.id (Sym.pp_string x))) + (compile_oargs v_bt [] + |> List.map_fst (fun x -> Id.make here (Sym.pp_string x))) in let y = Sym.fresh () in if BT.equal (BT.Record []) ret_bt then @@ -238,7 +241,7 @@ let rec compile_it_lat let it_ret = IT.recordMember_ ~member_bt:v_bt - (IT.sym_ (y, ret_bt, loc), Id.id "cn_return") + (IT.sym_ (y, ret_bt, loc), Id.make here "cn_return") loc in GT.let_ (0, (y, GT.call_ (fsym, args) ret_bt loc), GT.return_ it_ret loc) loc) @@ -259,7 +262,9 @@ let rec compile_it_lat | _ -> conv_fn oargs in let it_ret = - IT.record_ (List.map_fst (fun sym -> Id.id (Sym.pp_string sym)) it_oargs) here + IT.record_ + (List.map_fst (fun sym -> Id.make here (Sym.pp_string sym)) it_oargs) + here in return (GT.return_ it_ret (IT.get_loc it)) in diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index c1c62965c..bf603504a 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -684,7 +684,7 @@ module WIT = struct match List.assoc_opt Id.equal member members with | Some bt -> return bt | None -> - let expected = "struct with member " ^ Id.pp_string member in + let expected = "struct with member " ^ Id.get_string member in let reason = Either.Left loc in fail (illtyped_index_term loc t (IT.get_bt t) ~expected ~reason) in @@ -703,7 +703,7 @@ module WIT = struct match List.assoc_opt Id.equal member members with | Some bt -> return bt | None -> - let expected = "struct with member " ^ Id.pp_string member in + let expected = "struct with member " ^ Id.get_string member in let reason = Either.Left loc in fail (illtyped_index_term loc t (IT.get_bt t) ~expected ~reason) in From defd6eb849b2859fd5af3c5732183555195e387f Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Wed, 25 Dec 2024 15:39:35 +0000 Subject: [PATCH 124/148] CN: Use __LOC__ instead of __FUNCTION__ It's shorter, prints nicer and more helpfully. --- backend/cn/lib/alloc.ml | 2 +- backend/cn/lib/argumentTypes.ml | 2 +- backend/cn/lib/cLogicalFuns.ml | 8 +- backend/cn/lib/check.ml | 74 +++++++++---------- backend/cn/lib/cn_internal_to_ail.ml | 29 ++++---- backend/cn/lib/compile.ml | 18 ++--- backend/cn/lib/context.ml | 2 +- backend/cn/lib/core_to_mucore.ml | 10 +-- backend/cn/lib/definition.ml | 6 +- backend/cn/lib/diagnostics.ml | 17 ++--- backend/cn/lib/explain.ml | 6 +- backend/cn/lib/indexTerms.ml | 14 ++-- backend/cn/lib/lemmata.ml | 2 +- backend/cn/lib/logicalArgumentTypes.ml | 2 +- backend/cn/lib/logicalReturnTypes.ml | 2 +- backend/cn/lib/mucore.ml | 2 +- backend/cn/lib/pack.ml | 4 +- backend/cn/lib/resource.ml | 4 +- backend/cn/lib/resourceInference.ml | 24 +++--- backend/cn/lib/returnTypes.ml | 2 +- backend/cn/lib/simplify.ml | 8 +- backend/cn/lib/solver.ml | 8 +- backend/cn/lib/source_injection.ml | 6 +- backend/cn/lib/typing.ml | 14 ++-- backend/cn/lib/wellTyped.ml | 26 +++---- tests/cn/reverse.error.c.verify | 2 +- tests/cn/tree16/as_mutual_dt/tree16.c.verify | 4 +- .../cn/tree16/as_partial_map/tree16.c.verify | 4 +- 28 files changed, 152 insertions(+), 150 deletions(-) diff --git a/backend/cn/lib/alloc.ml b/backend/cn/lib/alloc.ml index a65282a34..3906e9296 100644 --- a/backend/cn/lib/alloc.ml +++ b/backend/cn/lib/alloc.ml @@ -3,7 +3,7 @@ module History = struct let sym = Sym.fresh_named str - let here = Locations.other __FUNCTION__ + let here = Locations.other __LOC__ let base_id = Id.make here "base" diff --git a/backend/cn/lib/argumentTypes.ml b/backend/cn/lib/argumentTypes.ml index 55b97f2e1..2025efc6e 100644 --- a/backend/cn/lib/argumentTypes.ml +++ b/backend/cn/lib/argumentTypes.ml @@ -91,7 +91,7 @@ let binders i_binders i_subst = let rec aux = function | Computational ((s, bt), _, t) -> let s, t = alpha_rename i_subst s t in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (Id.make here (Sym.pp_string s), bt) :: aux t | L t -> LAT.binders i_binders i_subst t in diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index 33e003b27..3d269c197 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -53,7 +53,7 @@ let init_state = { loc_map = IntMap.empty; next_loc = 1 } let mk_local_ptr state src_loc = let loc_ix = state.next_loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let ptr = IT.apply_ local_sym_ptr [ IT.int_ loc_ix here ] BT.(Loc ()) src_loc in let loc_map = IntMap.add loc_ix None state.loc_map in let state = { loc_map; next_loc = loc_ix + 1 } in @@ -360,7 +360,7 @@ let rec symb_exec_pexpr ctxt var_map pexpr = in (match ct with | Sctypes.Integer Sctypes.IntegerTypes.Bool -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in simp_const_pe (bool_ite_1_0 bool_rep_ty @@ -376,7 +376,7 @@ let rec symb_exec_pexpr ctxt var_map pexpr = | PEbounded_binop (bk, op, pe_x, pe_y) -> let@ x = self var_map pe_x in let@ y = self var_map pe_y in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let it = match op with | IOpAdd -> IT.add_ (x, y) loc @@ -619,7 +619,7 @@ let rec get_ret_it loc body bt = function let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_decl) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let def_args = def.Definition.Function.args (* TODO - add location information to binders *) diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index a05f28c51..657333970 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -100,7 +100,7 @@ let check_ptrval (loc : Locations.t) ~(expect : BT.t) (ptrval : pointer_value) : (* just to make sure it exists *) let@ _fun_loc, _, _ = get_fun_decl loc sym in (* the symbol of a function is the same as the symbol of its address *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in return (sym_ (sym, BT.(Loc ()), here))) (fun prov p -> let@ alloc_id = @@ -268,7 +268,7 @@ let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = (* try to follow is_representable_integer from runtime/libcore/std.core *) let is_representable_integer arg ity = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let bt = IT.get_bt arg in let arg_bits = Option.get (BT.is_bits_bt bt) in let maxInt = Memory.max_integer_type ity in @@ -309,7 +309,7 @@ let try_prove_constant loc expr = fail (fun _ -> { loc; msg = Generic (!^"model constant calculation:" ^^^ !^msg) }) in let fail_on_none msg = function Some m -> return m | None -> fail2 msg in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ m = model_with loc (IT.bool_ true here) in let@ m = fail_on_none "cannot get model" m in let@ y = fail_on_none "cannot eval term" (Solver.eval (fst m) expr) in @@ -386,7 +386,7 @@ let check_conv_int loc ~expect ct arg = in let bt = IT.get_bt arg in (* TODO: can we (later) optimise this? *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ value = match ity with | Bool -> @@ -432,7 +432,7 @@ let check_has_alloc_id loc ptr ub_unspec = let in_bounds ptr = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let module H = Alloc.History in let H.{ base; size } = H.(split (lookup_ptr ptr here) here) in let addr = addr_ ptr here in @@ -442,7 +442,7 @@ let in_bounds ptr = let check_both_eq_alloc loc arg1 arg2 ub = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let both_alloc = and_ [ hasAllocId_ arg1 here; @@ -468,7 +468,7 @@ let check_live_alloc_bounds ?(skip_live = false) reason loc ub ptrs = else RI.Special.check_live_alloc reason loc (List.hd ptrs) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let constr = and_ (List.concat_map in_bounds ptrs) here in let@ provable = provable loc in match provable @@ LC.T constr with @@ -492,7 +492,7 @@ let valid_for_deref loc pointer ct = let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let orig_pe = pe in let (Mu.Pexpr (loc, _, expect, pe_)) = pe in - let@ omodel = model_with loc (bool_ true @@ Locations.other __FUNCTION__) in + let@ omodel = model_with loc (bool_ true @@ Locations.other __LOC__) in let@ () = print_with_ctxt (fun ctxt -> debug 3 (lazy (action "inferring pure expression")); @@ -649,7 +649,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = check_pexpr pe2 (fun v2 -> let@ provable = provable loc in let v2_bt = Mu.bt_of_pexpr pe2 in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (ne_ (v2, int_lit_ 0 v2_bt here) here)) with | `True -> k (div_ (v1, v2) loc) | `False -> @@ -664,7 +664,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = check_pexpr pe2 (fun v2 -> let@ provable = provable loc in let v2_bt = Mu.bt_of_pexpr pe2 in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (ne_ (v2, int_lit_ 0 v2_bt here) here)) with | `True -> k (rem_ (v1, v2) loc) | `False -> @@ -829,7 +829,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let arg1_bt_range = BT.bits_range (Option.get (BT.is_bits_bt (IT.get_bt arg1))) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let arg2_bits_lost = IT.not_ (IT.in_z_range arg2 arg1_bt_range here) here in let x = match iop with @@ -870,7 +870,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> let large_bt = BT.Bits (BT.Signed, (2 * bits) + 4) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let large x = cast_ large_bt x here in let direct_x, via_large_x, premise = match iop with @@ -950,7 +950,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = 5 (lazy (Pp.item ("checking consistency of " ^ name ^ "-branch") (IT.pp cond))); let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (bool_ false here)) with | `True -> Pp.debug 5 (lazy (Pp.headline "inconsistent, skipping")); @@ -960,7 +960,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = check_pexpr e k in let@ () = pure (aux e1 c "then") in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ () = pure (aux e2 (not_ c here) "else") in return ()) | PElet (p, e1, e2) -> @@ -973,7 +973,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = k lvt)) | PEundef (loc, ub) -> let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (match provable (LC.T (bool_ false here)) with | `True -> return () | `False -> @@ -981,7 +981,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } })) | PEerror (err, _pe) -> let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (match provable (LC.T (bool_ false here)) with | `True -> return () | `False -> @@ -1298,7 +1298,7 @@ let add_trace_information _labels annots = let bytes_qpred sym size pointer init : Req.QPredicate.t = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let bt' = WellTyped.quantifier_bt in { q = (sym, bt'); q_loc = here; @@ -1313,7 +1313,7 @@ let bytes_qpred sym size pointer init : Req.QPredicate.t = let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let (Expr (loc, annots, expect, e_)) = e in let@ () = add_trace_information labels annots in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ omodel = model_with loc (bool_ true here) in match omodel with | None -> @@ -1327,7 +1327,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = debug 3 (lazy (item "ctxt" (Context.pp ctxt)))) in let bytes_qpred sym ct pointer init : Req.QPredicate.t = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in bytes_qpred sym (sizeOf_ ct here) pointer init in (match e_ with @@ -1335,7 +1335,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe) in check_pexpr pe (fun lvt -> k lvt) | Ememop memop -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let pointer_eq ?(negate = false) pe1 pe2 = let@ () = WellTyped.ensure_base_type loc ~expect Bool in let k, case, res = @@ -1468,7 +1468,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = allocations are exposed. (2) So, the only UB possible is unrepresentable results. *) let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let lc = LC.T (representable_ (act_to.ct, arg) here) in let@ () = match provable lc with @@ -1556,7 +1556,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k result)) | PtrMemberShift _ -> unsupported - (Loc.other __FUNCTION__) + (Loc.other __LOC__) !^"PtrMemberShift should be a CHERI only construct" | CopyAllocId (pe1, pe2) -> let@ () = @@ -1673,7 +1673,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = representable and done the right thing. Pointers, as I understand, are an exception. *) let@ () = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let in_range_lc = representable_ (act.ct, varg) here in let@ provable = provable loc in let holds = provable (LC.T in_range_lc) in @@ -1766,7 +1766,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let aux lc _nm e = let@ () = add_c loc (LC.T lc) in let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (bool_ false here)) with | `True -> return () | `False -> check_expr labels e k @@ -1812,7 +1812,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in let bytes_constraints ~(value : IT.t) ~(byte_arr : IT.t) (ct : Sctypes.t) = (* FIXME this hard codes big endianness but this should be switchable *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match ct with | Sctypes.Void | Array (_, _) | Struct _ | Function (_, _, _) -> assert false | Integer it -> @@ -2030,7 +2030,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = add_c loc (LC.T it) in debug 5 (lazy (item ("splitting case " ^ nm) (IT.pp it))); let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (bool_ false here)) with | `True -> Pp.debug 5 (lazy (Pp.headline "inconsistent, skipping")); @@ -2194,7 +2194,7 @@ let record_tagdefs tagDefs = PmapM.iterM (fun tag def -> match def with - | Mu.UnionDef -> unsupported (Loc.other __FUNCTION__) !^"todo: union types" + | Mu.UnionDef -> unsupported (Loc.other __LOC__) !^"todo: union types" | StructDef layout -> add_struct_decl tag layout) tagDefs @@ -2204,7 +2204,7 @@ let check_tagdefs tagDefs = (fun _tag def -> let open Memory in match def with - | Mu.UnionDef -> unsupported (Loc.other __FUNCTION__) !^"todo: union types" + | Mu.UnionDef -> unsupported (Loc.other __LOC__) !^"todo: union types" | StructDef layout -> let@ _ = ListM.fold_rightM @@ -2214,7 +2214,7 @@ let check_tagdefs tagDefs = (* this should have been checked earlier by the frontend *) assert false | Some (name, ct) -> - let@ () = WellTyped.WCT.is_ct (Loc.other __FUNCTION__) ct in + let@ () = WellTyped.WCT.is_ct (Loc.other __LOC__) ct in return (IdSet.add name have) | None -> return have) layout @@ -2286,11 +2286,11 @@ let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> unit m = (fun (sym, def) -> match def with | Mu.GlobalDef (ct, _) | GlobalDecl ct -> - let@ () = WellTyped.WCT.is_ct (Loc.other __FUNCTION__) ct in + let@ () = WellTyped.WCT.is_ct (Loc.other __LOC__) ct in let bt = BT.(Loc ()) in - let info = (Loc.other __FUNCTION__, lazy (Pp.item "global" (Sym.pp sym))) in + let info = (Loc.other __LOC__, lazy (Pp.item "global" (Sym.pp sym))) in let@ () = add_a sym bt info in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ () = add_c here (LC.T (IT.good_pointer ~pointee_ct:ct (sym_ (sym, bt, here)) here)) in @@ -2486,7 +2486,7 @@ let wf_check_and_record_lemma (lemma_s, (loc, lemma_typ)) = let ctz_proxy_ft = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let info = (here, Some "ctz_proxy builtin ft") in let n_sym, n = IT.fresh_named BT.(Bits (Unsigned, 32)) "n_" here in let ret_sym, ret = IT.fresh_named BT.(Bits (Signed, 32)) "return" here in @@ -2511,11 +2511,11 @@ let ctz_proxy_ft = let ffs_proxy_ft sz = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let sz_name = CF.Pp_ail.string_of_integerBaseType sz in let bt = Memory.bt_of_sct Sctypes.(Integer (Signed sz)) in let ret_bt = Memory.bt_of_sct Sctypes.(Integer (Signed Int_)) in - let info = (Locations.other __FUNCTION__, Some ("ffs_proxy builtin ft: " ^ sz_name)) in + let info = (Locations.other __LOC__, Some ("ffs_proxy builtin ft: " ^ sz_name)) in let n_sym, n = IT.fresh_named bt "n_" here in let ret_sym, ret = IT.fresh_named ret_bt "return" here in let eq_ffs = @@ -2530,7 +2530,7 @@ let ffs_proxy_ft sz = let memcpy_proxy_ft = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let info = (here, Some "memcpy_proxy") in (* C arguments *) let dest_sym, dest = IT.fresh_named (BT.Loc ()) "dest" here in @@ -2591,7 +2591,7 @@ let add_stdlib_spec = Pp.debug 2 (lazy (Pp.headline ("adding builtin spec for procedure " ^ Sym.pp_string fsym))); - add_fun_decl fsym (Locations.other __FUNCTION__, Some ft, ct) + add_fun_decl fsym (Locations.other __LOC__, Some ft, ct) in fun call_sigs fsym -> match diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 79a0ae08e..2cf75ca01 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -72,7 +72,7 @@ let generic_cn_dt_sym = Sym.fresh_pretty "cn_datatype" let create_id_from_sym ?(lowercase = false) sym = let str = Sym.pp_string sym in let str = if lowercase then String.lowercase_ascii str else str in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in Id.make here str @@ -96,6 +96,7 @@ let generate_error_msg_info_update_stats ?(cn_source_loc_opt = None) () = | Some loc -> let loc_str = Cerb_location.location_to_string loc in let _, loc_str_2 = Cerb_location.head_pos_of_location loc in + let loc_str_escaped = Str.global_replace (Str.regexp_string "\"") "\'" loc_str in let loc_str_2_escaped = Str.global_replace (Str.regexp_string "\n") "\\n" loc_str_2 in @@ -104,7 +105,9 @@ let generate_error_msg_info_update_stats ?(cn_source_loc_opt = None) () = in let cn_source_loc_str = mk_expr - A.(AilEstr (None, [ (Cerb_location.unknown, [ loc_str_2_escaped ^ loc_str ]) ])) + A.( + AilEstr + (None, [ (Cerb_location.unknown, [ loc_str_2_escaped ^ loc_str_escaped ]) ])) in cn_source_loc_str | None -> mk_expr A.(AilEconst ConstantNull) @@ -142,9 +145,9 @@ let rec bt_to_cn_base_type = function | Bits (sign, size) -> CN_bits ((match sign with Unsigned -> CN_unsigned | Signed -> CN_signed), size) | Real -> CN_real - | MemByte -> failwith (__FUNCTION__ ^ ": TODO MemByte") + | MemByte -> failwith (__LOC__ ^ ": TODO MemByte") | Alloc_id -> CN_alloc_id - | CType -> failwith (__FUNCTION__ ^ ": TODO Ctype") + | CType -> failwith (__LOC__ ^ ": TODO Ctype") | Loc () -> CN_loc | Struct tag -> CN_struct tag | Datatype tag -> CN_datatype tag @@ -223,7 +226,7 @@ let rec cn_to_ail_base_type ?pred_sym:(_ = None) cn_typ = generate_ail_array bt (* TODO: What is the optional second pair element for? Have just put None for now *) | CN_tuple _ts -> - failwith (__FUNCTION__ ^ ":Tuples not yet supported") + failwith (__LOC__ ^ ":Tuples not yet supported") (* Printf.printf "Entered CN_tuple case\n"; *) (* let some_id = create_id_from_sym (Sym.fresh_pretty "some_sym") in let members = List.map (fun t -> (some_id, t)) ts in @@ -678,7 +681,7 @@ let generate_get_or_put_ownership_function ~without_ownership_checking ctype let ctype_str = String.concat "_" (String.split_on_char ' ' ctype_str) in let fn_sym = Sym.fresh_pretty ("owned_" ^ ctype_str) in let param1_sym = Sym.fresh_pretty "cn_ptr" in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let cast_expr = mk_expr A.( @@ -1097,7 +1100,7 @@ let rec cn_to_ail_expr_aux_internal in let ail_decl = A.(AilSdeclaration [ (res_sym, Some (mk_expr fn_call)) ]) in let lc_constr_sym = generate_sym_with_suffix ~suffix:"" ~lowercase:true sym in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let e_ = A.(AilEmemberofptr (mk_expr res_ident, Id.make here "u")) in let e_' = A.(AilEmemberof (mk_expr e_, create_id_from_sym lc_constr_sym)) in let generate_ail_stat (id, it) = @@ -1319,7 +1322,7 @@ let rec cn_to_ail_expr_aux_internal | _ :: _ -> failwith "Non-sum pattern" | [] -> assert false in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let transform_switch_expr e = A.(AilEmemberofptr (e, Id.make here "tag")) in (* Matrix algorithm for pattern compilation *) let rec translate @@ -1574,7 +1577,7 @@ let generate_map_get sym = let ret_sym = Sym.fresh_pretty "ret" in let ret_binding = create_binding ret_sym void_ptr_type in let key_val_mem = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in mk_expr A.(AilEmemberofptr (mk_expr (AilEident param2_sym), Id.make here "val")) in let ht_get_fcall = @@ -1635,7 +1638,7 @@ let cn_to_ail_datatype ?(first = false) (cn_datatype : cn_datatype) = let enum_sym = generate_sym_with_suffix cn_datatype.cn_dt_name in let constructor_syms = List.map fst cn_datatype.cn_dt_cases in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let generate_enum_member sym = let doc = CF.Pp_ail.pp_id sym in let str = CF.Pp_utils.to_plain_string doc in @@ -1724,7 +1727,7 @@ let generate_datatype_equality_function (cn_datatype : cn_datatype) let fn_sym = Sym.fresh_pretty ("struct_" ^ Sym.pp_string dt_sym ^ "_equality") in let param1_sym = Sym.fresh_pretty "x" in let param2_sym = Sym.fresh_pretty "y" in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let id_tag = Id.make here "tag" in let param_syms = [ param1_sym; param2_sym ] in let param_type = @@ -1901,7 +1904,7 @@ let generate_datatype_default_function (cn_datatype : cn_datatype) = } in let enum_ident = mk_expr A.(AilEident enum_sym) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let res_tag_assign = A.( AilSexpr @@ -3468,7 +3471,7 @@ let generate_assume_ownership_function ~without_ownership_checking ctype let ctype_str = String.concat "_" (String.split_on_char ' ' ctype_str) in let fn_sym = Sym.fresh_pretty ("assume_owned_" ^ ctype_str) in let param1_sym = Sym.fresh_pretty "cn_ptr" in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let cast_expr = mk_expr A.( diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 1875f0f4a..abbdaaa9f 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -238,7 +238,7 @@ let rec translate_cn_base_type env (bTy : CF.Symbol.sym cn_base_type) = failwith "user type-abbreviation not removed by cabs->ail elaboration" | CN_c_typedef_name sym -> (* FIXME handle errors here properly *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (match env.fetch_typedef here sym with | Result.Ok r -> Memory.sbt_of_sct (Sctypes.of_ctype_unsafe here r) | Result.Error e -> failwith (Pp.plain TypeErrors.((pp_message e.msg).short))) @@ -469,7 +469,7 @@ module EffectfulTranslation = struct | CN_sub, Loc oct -> (match oct with | Some ct -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let (IT (it_, _, _)) = Surface.inj (arrayShift_ @@ -1082,13 +1082,13 @@ module EffectfulTranslation = struct let msg_s = "Iterated predicate pointer must be array_shift(ptr, q_var):" in match IT.get_term ptr_expr with | ArrayShift { base = p; ct; index = x } when Terms.equal_annot SBT.equal x qs -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in return (p, IT.cast_ (SBT.proj bt) (IT.sizeOf_ ct here) here) | _ -> fail { loc; msg = Generic (!^msg_s ^^^ IT.pp ptr_expr) } let owned_good _sym (res_t, _oargs_ty) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match res_t with | Req.P { pointer; name = Owned (scty, _); _ } -> [ ( LC.T (IT.good_ (Pointer scty, pointer) here), @@ -1117,7 +1117,7 @@ module EffectfulTranslation = struct let pointee_value = match pname with | Owned (_, Init) -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in [ (ptr_expr, IT.sym_ (sym, oargs_ty, here)) ] | _ -> [] in @@ -1132,7 +1132,7 @@ module EffectfulTranslation = struct let@ pname, ptr_expr, iargs, oargs_ty = translate_cn_res_info res_loc pred_loc env_with_q res args in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ ptr_base, step = split_pointer_linear_step pred_loc (q, bt', here) ptr_expr in let m_oargs_ty = SBT.make_map_bt bt' oargs_ty in let pt = @@ -1380,7 +1380,7 @@ let translate_cn_clauses env clauses = let rec self acc = function | CN_clause (loc, cl_) -> let@ cl = translate_cn_clause env cl_ in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in return (Def.Clause.{ loc; guard = IT.bool_ true here; packing_ft = cl } :: acc) | CN_if (loc, e_, cl_, clauses') -> let@ e = @@ -1493,7 +1493,7 @@ let make_rt loc (env : env) st (s, ct) (accesses, ensures) = make_lrt_with_accesses (add_computational s sbt env) st (accesses, ensures) in (* let info = (loc, Some "return value good") in *) - (* let here = Locations.other __FUNCTION__ in *) + (* let here = Locations.other __LOC__ in *) (* let lrt = LRT.mConstraint (LC.T (IT.good_ (ct, IT.sym_ (s, bt, here)) here), info) lrt in *) return (RT.mComputational ((s, bt), (loc, None)) lrt) @@ -1565,7 +1565,7 @@ module UsingLoads = struct | ScopeExists (_loc, scope, k) -> aux (k (StringMap.mem scope old_states)) and load loc action_pp pointer k = let@ pointee_ct = pointee_ct loc pointer in - let value_loc = Locations.other __FUNCTION__ in + let value_loc = Locations.other __LOC__ in let value_s = Sym.fresh_make_uniq (action_pp ^ "_" ^ Pp.plain (IT.pp pointer)) in let value_bt = Memory.sbt_of_sct pointee_ct in let value = IT.sym_ (value_s, value_bt, value_loc) in diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index 247a3276e..3bd243713 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -201,7 +201,7 @@ let res_map_history m id = match IntMap.find_opt id m with | Some h -> h | None -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in { last_written = here; reason_written = "unknown"; last_written_id = id; diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 4b85fe428..894a1e214 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -628,7 +628,7 @@ let n_memop ~inherit_loc loc memop pexprs = | PtrMemberShift _, _ -> assert_error loc !^"PtrMemberShift (CHERI only)" | memop, pexprs1 -> let err = - !^__FUNCTION__ + !^__LOC__ ^^ colon ^^^ !^(show_n_memop memop) ^^^ !^"applied to" @@ -943,7 +943,7 @@ let make_label_args f_i loc env st args (accesses, inv) = let env = C.add_computational s p_sbt env in (* let good_pointer_lc = *) (* let info = (loc, Some (Sym.pp_string s ^ " good")) in *) - (* let here = Locations.other __FUNCTION__ in *) + (* let here = Locations.other __LOC__ in *) (* (LC.T (IT.good_ (Pointer sct, IT.sym_ (s, BT.Loc, here)) here), info) *) (* in *) let@ oa_name, ((pt_ret, oa_bt), lcs), value = C.ownership (loc, (s, ct)) env in @@ -980,7 +980,7 @@ let make_function_args f_i loc env args (accesses, requires) = let st = C.LocalState.add_c_variable_state mut_arg arg_state st in (* let good_lc = *) (* let info = (loc, Some (Sym.pp_string pure_arg ^ " good")) in *) - (* let here = Locations.other __FUNCTION__ in *) + (* let here = Locations.other __LOC__ in *) (* (LC.T (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) (* in *) let@ at = @@ -1019,7 +1019,7 @@ let make_fun_with_spec_args f_i loc env args requires = let env = C.add_computational pure_arg sbt env in (* let good_lc = *) (* let info = (loc, Some (Sym.pp_string pure_arg ^ " good")) in *) - (* let here = Locations.other __FUNCTION__ in *) + (* let here = Locations.other __LOC__ in *) (* (LC.T (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) (* in *) let@ at = aux (* good_lc :: *) good_lcs env st rest in @@ -1426,7 +1426,7 @@ let normalise_fun_map let normalise_globs ~inherit_loc env _sym g = - let loc = Locations.other __FUNCTION__ in + let loc = Locations.other __LOC__ in match g with | GlobalDef ((bt, ct), e) -> let@ () = check_against_core_bt loc bt BT.(Loc ()) in diff --git a/backend/cn/lib/definition.ml b/backend/cn/lib/definition.ml index 4db2a43a0..3da6d997f 100644 --- a/backend/cn/lib/definition.ml +++ b/backend/cn/lib/definition.ml @@ -110,7 +110,7 @@ module Clause = struct | LAT.Resource (bound, info, lat) -> LRT.Resource (bound, info, aux lat) | LAT.Constraint (lc, info, lat) -> LRT.Constraint (lc, info, aux lat) | I output -> - let loc = Locations.other __FUNCTION__ in + let loc = Locations.other __LOC__ in let lc = LogicalConstraints.T (IT.eq_ (pred_oarg, output) loc) in LRT.Constraint (lc, (loc, None), LRT.I) in @@ -162,7 +162,7 @@ module Predicate = struct (match provable (LogicalConstraints.T clause.guard) with | `True -> Some clause | `False -> - let loc = Locations.other __FUNCTION__ in + let loc = Locations.other __LOC__ in (match provable (LogicalConstraints.T (IT.not_ clause.guard loc)) with | `True -> try_clauses clauses | `False -> @@ -187,7 +187,7 @@ end let alloc = Predicate. - { loc = Locations.other (__FILE__ ^ ":" ^ string_of_int __LINE__); + { loc = Locations.other __LOC__; pointer = Sym.fresh_named "ptr"; iargs = []; oarg_bt = Alloc.History.value_bt; diff --git a/backend/cn/lib/diagnostics.ml b/backend/cn/lib/diagnostics.ml index f1b3ee3de..b22277552 100644 --- a/backend/cn/lib/diagnostics.ml +++ b/backend/cn/lib/diagnostics.ml @@ -53,7 +53,7 @@ let term_with_model_name nm cfg x = return (bold nm ^^ colon ^^^ parens (string "cannot eval") ^^ colon ^^^ IT.pp x) | Some r -> if IT.is_true r || IT.is_false r then ( - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ p = provable here in let info = match p (LC.T (IT.eq_ (x, r) here)) with @@ -140,7 +140,7 @@ let rec investigate_term cfg t = match split_eq x y with | None -> return [] | Some bits -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in ListM.mapM (fun (x, y) -> rec_opt "parametric eq" (IT.eq_ (x, y) here)) bits in return (List.concat trans_opts @ [ get_eq_opt ] @ split_opts) @@ -184,7 +184,7 @@ and investigate_eq_side _cfg (side_nm, t, t2) = { doc = IT.pp t; continue = (fun cfg -> - let eq = IT.eq_ (t, t2) @@ Locations.other __FUNCTION__ in + let eq = IT.eq_ (t, t2) @@ Locations.other __LOC__ in print stdout (bold "investigating eq:" ^^^ IT.pp eq); investigate_term cfg eq) }) @@ -220,7 +220,7 @@ and investigate_trans_eq t cfg = |> ITSet.elements in let opt_of x = - let eq = IT.eq_ (t, x) @@ Locations.other __FUNCTION__ in + let eq = IT.eq_ (t, x) @@ Locations.other __LOC__ in let@ doc = term_with_model_name "eq to constraint elem" cfg eq in return { doc; continue = (fun cfg -> investigate_term cfg eq) } in @@ -246,10 +246,10 @@ and get_eqs_then_investigate cfg x y = cs in let opt_xs = ITSet.elements x_set in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ () = test_value_eqs here None x opt_xs in let@ () = test_value_eqs here None y opt_xs in - investigate_term cfg (IT.eq_ (x, y) @@ Locations.other __FUNCTION__) + investigate_term cfg (IT.eq_ (x, y) @@ Locations.other __LOC__) and investigate_pred cfg nm t = @@ -270,8 +270,7 @@ and investigate_pred cfg nm t = return { doc; continue = - (fun cfg -> - investigate_term cfg (IT.eq_ (t, p) @@ Locations.other __FUNCTION__)) + (fun cfg -> investigate_term cfg (IT.eq_ (t, p) @@ Locations.other __LOC__)) } in ListM.mapM pred_opt ps @@ -299,7 +298,7 @@ and investigate_ite cfg t = continue = (fun cfg -> let open Pp in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let t' = simp x (IT.bool_ b here) t in print stdout (bold "rewrote to:" ^^^ IT.pp t'); print diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index f6471be02..f1a2e7ce4 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -219,7 +219,7 @@ let state ctxt log model_with_q extras = in let terms = let variables = - let make s ls = sym_ (s, ls, Locations.other __FUNCTION__) in + let make s ls = sym_ (s, ls, Locations.other __LOC__) in let basetype_binding (s, (binding, _)) = match binding with Value _ -> None | BaseType ls -> Some (make s ls) in @@ -232,7 +232,7 @@ let state ctxt log model_with_q extras = match extras.unproven_constraint with | Some (T lc) -> subterms_without_bound_variables [] lc | Some (Forall ((s, bt), lc)) -> - let binder = (Pat (PSym s, bt, Loc.other __FUNCTION__), None) in + let binder = (Pat (PSym s, bt, Loc.other __LOC__), None) in subterms_without_bound_variables [ binder ] lc | None -> ITSet.empty in @@ -241,7 +241,7 @@ let state ctxt log model_with_q extras = | Some (P ret) -> ITSet.bigunion_map (subterms_without_bound_variables []) (ret.pointer :: ret.iargs) | Some (Q ret) -> - let binder = (Pat (PSym (fst ret.q), snd ret.q, Loc.other __FUNCTION__), None) in + let binder = (Pat (PSym (fst ret.q), snd ret.q, Loc.other __LOC__), None) in ITSet.union (ITSet.bigunion_map (subterms_without_bound_variables []) diff --git a/backend/cn/lib/indexTerms.ml b/backend/cn/lib/indexTerms.ml index e0371568b..669b1aa10 100644 --- a/backend/cn/lib/indexTerms.ml +++ b/backend/cn/lib/indexTerms.ml @@ -164,7 +164,7 @@ let rec fold_ f binders acc = function | ITE (t1, t2, t3) -> fold_list f binders acc [ t1; t2; t3 ] | EachI ((_, (s, bt), _), t) -> (* TODO - add location information to binders *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in fold f (binders @ [ (Pat (PSym s, bt, here), None) ]) acc t | Tuple ts -> fold_list f binders acc ts | NthTuple (_, t) -> fold f binders acc t @@ -196,13 +196,13 @@ let rec fold_ f binders acc = function | MapGet (t1, t2) -> fold_list f binders acc [ t1; t2 ] | MapDef ((s, bt), t) -> (* TODO - add location information to binders *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in fold f (binders @ [ (Pat (PSym s, bt, here), None) ]) acc t | Apply (_pred, ts) -> fold_list f binders acc ts | Let ((nm, t1), t2) -> let acc' = fold f binders acc t1 in (* TODO - add location information to binders *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in fold f (binders @ [ (Pat (PSym nm, get_bt t1, here), Some t1) ]) acc' t2 | Match (e, cases) -> (* TODO: check this is good *) @@ -1000,7 +1000,7 @@ let value_check mode (struct_layouts : Memory.struct_decls) ct about loc = () else Pp.warn - (Locations.other __FUNCTION__) + (Locations.other __LOC__) (Pp.item "unexpected type of array arg" (pp_with_typ about)) in let i_s, i = fresh ix_bt loc in @@ -1044,7 +1044,7 @@ let promote_to_compare it it' loc = let nth_array_to_list_fact n xs d = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match get_term xs with | ArrayToList (arr, i, len) -> let lt_n_len = lt_ (promote_to_compare n len here) here in @@ -1075,7 +1075,7 @@ let rec wrap_bindings_match bs default_v v = match x with | None -> None | Some match_e -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in Some (IT ( Match @@ -1086,7 +1086,7 @@ let rec wrap_bindings_match bs default_v v = let nth_array_to_list_facts (binders_terms : (t_bindings * t) list) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let nths = List.filter_map (fun (bs, it) -> diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index 8b840648f..3526ce5a6 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -836,7 +836,7 @@ let ensure_struct_mem is_good global list_mono loc ct aux = (lazy (let@ ty = bt_to_coq global list_mono (loc, Pp.string op_nm) bt in let x = Pp.parens (Pp.typ (Pp.string "x") ty) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let x_it = IT.sym_ (Sym.fresh_named "x", bt, here) in let@ rhs = aux (it_adjust global (IT.good_value global.struct_decls ct x_it here)) diff --git a/backend/cn/lib/logicalArgumentTypes.ml b/backend/cn/lib/logicalArgumentTypes.ml index c7bf56ac9..b6ff88f17 100644 --- a/backend/cn/lib/logicalArgumentTypes.ml +++ b/backend/cn/lib/logicalArgumentTypes.ml @@ -164,7 +164,7 @@ let alpha_unique ss = let binders i_binders i_subst = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let rec aux = function | Define ((s, it), _, t) -> let s, t = alpha_rename i_subst s t in diff --git a/backend/cn/lib/logicalReturnTypes.ml b/backend/cn/lib/logicalReturnTypes.ml index b2165e170..445ca9303 100644 --- a/backend/cn/lib/logicalReturnTypes.ml +++ b/backend/cn/lib/logicalReturnTypes.ml @@ -84,7 +84,7 @@ let alpha_unique ss = let binders = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let rec aux = function | Define ((s, it), _, t) -> let s, t = alpha_rename s t in diff --git a/backend/cn/lib/mucore.ml b/backend/cn/lib/mucore.ml index 6c417d27c..e5d915fa2 100644 --- a/backend/cn/lib/mucore.ml +++ b/backend/cn/lib/mucore.ml @@ -86,7 +86,7 @@ let fun_param_types mu_fun = let evaluate_fun mu_fun args = let module IT = IndexTerms in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match mu_fun with | F_params_length -> (match args with diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index beba8b43f..d0a548040 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -10,7 +10,7 @@ module LC = LogicalConstraints (* open Cerb_pp_prelude *) let resource_empty provable resource = - let loc = Cerb_location.other __FUNCTION__ in + let loc = Cerb_location.other __LOC__ in let constr = match resource with | P _, _ -> LC.T (IT.bool_ false loc) @@ -159,7 +159,7 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O let index_permission = IT.subst su ret.permission in (match prove_or_model (LC.T index_permission) with | `True -> - let loc = Cerb_location.other __FUNCTION__ in + let loc = Cerb_location.other __LOC__ in let at_index = ( P { name = ret.name; diff --git a/backend/cn/lib/resource.ml b/backend/cn/lib/resource.ml index 0d6e0d436..7c2ff65fa 100644 --- a/backend/cn/lib/resource.ml +++ b/backend/cn/lib/resource.ml @@ -23,7 +23,7 @@ let free_vars (r, O oargs) = Sym.Set.union (Req.free_vars r) (IT.free_vars oargs (* assumption: the resource is owned *) let derived_lc1 ((resource : Req.t), O output) = - let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in + let here = Locations.other __LOC__ in match resource with | P { name = Owned (ct, _); pointer; iargs = _ } -> let addr = IT.addr_ pointer here in @@ -53,7 +53,7 @@ let derived_lc2 ((resource : Req.t), _) ((resource' : Req.t), _) = match (resource, resource') with | ( P { name = Owned (ct1, _); pointer = p1; iargs = _ }, P { name = Owned (ct2, _); pointer = p2; iargs = _ } ) -> - let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in + let here = Locations.other __LOC__ in let addr1 = IT.addr_ p1 here in let addr2 = IT.addr_ p2 here in let up1 = IT.upper_bound addr1 ct1 here in diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 81966b0ff..4d02ef98b 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -25,7 +25,7 @@ let debug_constraint_failure_diagnostics Pp.debug lvl (lazy (pp_f tm')) | _ -> Pp.warn - (Locations.other __FUNCTION__) + (Locations.other __LOC__) (Pp.bold "unexpected quantifier count with model") in diag "counterexample, expanding" c; @@ -58,7 +58,7 @@ module General = struct let add_case case (C cases) = C (cases @ [ case ]) let cases_to_map loc (situation, requests) a_bt item_bt (C cases) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let update_with_ones base_array ones = List.fold_left (fun m { one_index; value } -> IT.map_set_ m (one_index, value) here) @@ -113,7 +113,7 @@ module General = struct let@ o_re_oarg = resource_request loc uiinfo resource in (match o_re_oarg with | None -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ model = model_with loc (IT.bool_ true here) in let model = Option.get model in fail (fun ctxt -> @@ -158,8 +158,8 @@ module General = struct let rec predicate_request loc (uiinfo : uiinfo) (requested : Req.Predicate.t) : (Resource.predicate * int list) option m = - Pp.(debug 7 (lazy (item __FUNCTION__ (Req.pp (P requested))))); - let start_timing = Pp.time_log_start __FUNCTION__ "" in + Pp.(debug 7 (lazy (item __LOC__ (Req.pp (P requested))))); + let start_timing = Pp.time_log_start __LOC__ "" in let@ oarg_bt = WellTyped.oarg_bt_of_pred loc requested.name in let@ provable = provable loc in let@ global = get_global () in @@ -171,7 +171,7 @@ module General = struct else ( match re with | Req.P p', p'_oarg when Req.subsumed requested.name p'.name -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let addr_iargs_eqs = IT.(eq_ ((addr_ requested.pointer) here, addr_ p'.pointer here) here) :: List.map2 (fun x y -> IT.eq__ x y here) requested.iargs p'.iargs @@ -217,7 +217,7 @@ module General = struct | _re -> continue) in let needed = true in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ (needed, oarg), changed_or_deleted = map_and_fold_resources loc resource_scan (needed, O (IT.default_ oarg_bt here)) in @@ -247,7 +247,7 @@ module General = struct and qpredicate_request_aux loc uiinfo (requested : Req.QPredicate.t) = - Pp.(debug 7 (lazy (item __FUNCTION__ (Req.pp (Q requested))))); + Pp.(debug 7 (lazy (item __LOC__ (Req.pp (Q requested))))); let@ provable = provable loc in let@ simp_ctxt = simp_ctxt () in let needed = requested.permission in @@ -280,7 +280,7 @@ module General = struct && IT.equal step p'.step && BaseTypes.equal (snd requested.q) (snd p'.q) -> let p' = Req.QPredicate.alpha_rename_ (fst requested.q) p' in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let pmatch = (* Work-around for https://github.com/Z3Prover/z3/issues/7352 *) Simplify.IndexTerms.simp simp_ctxt @@ -321,7 +321,7 @@ module General = struct | _re -> continue)) (needed, C []) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ needed, oarg = let@ movable_indices = get_movable_indices () in let module Eff = Effectful.Make (Typing) in @@ -459,7 +459,7 @@ end module Special = struct let fail_missing_resource loc (situation, requests) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ model = model_with loc (IT.bool_ true here) in let model = Option.get model in fail (fun ctxt -> @@ -497,7 +497,7 @@ module Special = struct | Model of (Solver.model_with_q * IT.t) end in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let alloc_id_matches found res_ptr = let@ found in match found with diff --git a/backend/cn/lib/returnTypes.ml b/backend/cn/lib/returnTypes.ml index 48fdf88ab..a633e4529 100644 --- a/backend/cn/lib/returnTypes.ml +++ b/backend/cn/lib/returnTypes.ml @@ -43,7 +43,7 @@ let simp simp_it simp_lc simp_re = function let binders = function | Computational ((s, bt), _, t) -> let s, t = LRT.alpha_rename s t in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (Id.make here (Sym.pp_string s), bt) :: LRT.binders t diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index 1ef2fbdf4..71b52fc8d 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -36,9 +36,9 @@ let do_ctz_z z = module IndexTerms = struct - let z1 = z_ Z.one (Cerb_location.other __FUNCTION__) + let z1 = z_ Z.one (Cerb_location.other __LOC__) - let z0 = z_ Z.zero (Cerb_location.other __FUNCTION__) + let z0 = z_ Z.zero (Cerb_location.other __LOC__) let rec dest_int_addition ts it = let loc = IT.get_loc it in @@ -505,7 +505,7 @@ module IndexTerms = struct let a = aux a in let b = aux b in if isIntegerToPointerCast a || isIntegerToPointerCast b then ( - let loc = Cerb_location.other __FUNCTION__ in + let loc = Cerb_location.other __LOC__ in aux (lt_ (addr_ a loc, addr_ b loc) the_loc)) else if IT.equal a b then bool_ false the_loc @@ -515,7 +515,7 @@ module IndexTerms = struct let a = aux a in let b = aux b in if isIntegerToPointerCast a || isIntegerToPointerCast b then ( - let loc = Cerb_location.other __FUNCTION__ in + let loc = Cerb_location.other __LOC__ in aux (le_ (addr_ a loc, addr_ b loc) the_loc)) else if IT.equal a b then bool_ true the_loc diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 653417ba3..74ce31f59 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -700,7 +700,7 @@ let rec translate_term s iterm = SMT.let_ [ (x, e) ] (k (SMT.atom x))) in let default bt = - let here = Locations.other (__FUNCTION__ ^ string_of_int __LINE__) in + let here = Locations.other __LOC__ in translate_term s (IT.default_ bt here) in match IT.get_term iterm with @@ -735,11 +735,11 @@ let rec translate_term s iterm = (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_neg (translate_term s e1) | BT.Integer | BT.Real -> SMT.num_neg (translate_term s e1) - | _ -> failwith (__FUNCTION__ ^ ":Unop (Negate, _)")) + | _ -> failwith (__LOC__ ^ ":Unop (Negate, _)")) | BW_Compl -> (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_compl (translate_term s e1) - | _ -> failwith (__FUNCTION__ ^ ":Unop (BW_Compl, _)")) + | _ -> failwith (__LOC__ ^ ":Unop (BW_Compl, _)")) | BW_CLZ_NoSMT -> (match IT.get_bt iterm with | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_clz w w) @@ -1106,7 +1106,7 @@ type reduction = } let translate_goal solver assumptions lc = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let instantiated = match lc with | LC.T it -> { expr = translate_term solver it; qs = []; extra = [] } diff --git a/backend/cn/lib/source_injection.ml b/backend/cn/lib/source_injection.ml index f22bd4946..90718580f 100644 --- a/backend/cn/lib/source_injection.ml +++ b/backend/cn/lib/source_injection.ml @@ -39,7 +39,7 @@ end = struct let offset_col ~off pos = if pos.col + off < 0 then - Error (__FUNCTION__ ^ ": pos.col < off") + Error (__LOC__ ^ ": pos.col < off") else Ok { pos with col = pos.col + off } @@ -51,7 +51,7 @@ end = struct "\x1b[31mHEADER LOC: %s\x1b[0m\n" (Option.value ~default:"" (Cerb_location.get_filename loc)) ; *) match Cerb_location.to_cartesian loc with - | None -> Error (__FUNCTION__ ^ ": failed to get line/col positions") + | None -> Error (__LOC__ ^ ": failed to get line/col positions") | Some ((start_line, start_col), (end_line, end_col)) -> Ok (v (start_line + 1) (start_col + 1), v (end_line + 1) (end_col + 1)) end @@ -320,7 +320,7 @@ let pre_post_injs pre_post is_void is_main (A.AnnotatedStatement (loc, _, _)) = (* match stmt_ with | AilSblock (_bindings, []) -> Pos.of_location loc | AilSblock (_bindings, ss) -> let first = List.hd ss in let last = Lem_list_extra.last ss in let* (pre_pos, _) = posOf_stmt first in let* (_, post_pos) = posOf_stmt last in Ok - (pre_pos, post_pos) | _ -> Error (__FUNCTION__ ^ ": must be called on a function body + (pre_pos, post_pos) | _ -> Error (__LOC__ ^ ": must be called on a function body statement") in *) (* Printf.fprintf stderr "\x1b[35mPRE[%s], pos: %s\x1b[0m\n" (Cerb_location.location_to_string loc) (Pos.to_string pre_pos); Printf.fprintf stderr diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index a277ba030..df9cd162a 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -501,7 +501,7 @@ let model_has_prop () = let prove_or_model_with_past_model loc m = let@ has_prop = model_has_prop () in let@ p_f = provable_internal loc in - let loc = Locations.other __FUNCTION__ in + let loc = Locations.other __LOC__ in let res lc = match lc with | LC.T t when has_prop (IT.not_ t loc) m -> `Counterex (lazy m) @@ -521,7 +521,7 @@ let do_check_model loc m prop = |> List.filter (fun (_, (bt_or_v, _)) -> not (has_value bt_or_v)) |> List.map (fun (nm, (bt_or_v, (loc, _))) -> IT.sym_ (nm, bt_of bt_or_v, loc))) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let eqs = List.filter_map (fun v -> @@ -551,7 +551,7 @@ let model_with_internal loc prop = | Some m -> return (Some m) | None -> let@ prover = provable_internal loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (match prover (LC.T (IT.not_ prop here)) with | `True -> return None | `False -> @@ -651,7 +651,7 @@ let map_and_fold_resources_internal loc (f : Res.t -> 'acc -> changed * 'acc) (a let ix, hist = Context.res_written loc i "changed" (ix, hist) in (match re with | Q { q; permission; _ }, _ -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (match provable_f (LC.forall_ q (IT.not_ permission here)) with | `True -> (resources, ix, hist, i :: changed_or_deleted, acc) | `False -> @@ -677,11 +677,11 @@ let do_unfold_resources loc = let rec aux () = let@ s = get_typing_context () in let@ movable_indices = get_movable_indices () in - let@ _provable_f = provable_internal (Locations.other __FUNCTION__) in + let@ _provable_f = provable_internal (Locations.other __LOC__) in let resources, orig_ix = s.resources in let _orig_hist = s.resource_history in Pp.debug 8 (lazy (Pp.string "-- checking resource unfolds now --")); - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ true_m = model_with_internal loc (IT.bool_ true here) in match true_m with | None -> return () (* contradictory state *) @@ -791,7 +791,7 @@ let value_eq_group guard x = let test_value_eqs loc guard x ys = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let prop y = match guard with | None -> LC.T (IT.eq_ (x, y) here) diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index bf603504a..a37af727f 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -1041,7 +1041,7 @@ module WReq = struct (let@ () = add_l (fst p.q) (snd p.q) (loc, lazy (Pp.string "forall-var")) in let@ permission = WIT.check loc BT.Bool p.permission in (* let@ provable = provable loc in *) - (* let here = Locations.other __FUNCTION__ in *) + (* let here = Locations.other __LOC__ in *) (* let only_nonnegative_indices = *) (* (\* It is important to use `permission` here and NOT `p.permission`. *) (* If there is a record involved, `permission` is normalised but the @@ -1098,7 +1098,7 @@ let oarg_bt loc = function module WRS = struct let welltyped loc (resource, bt) = - Pp.(debug 6 (lazy !^__FUNCTION__)); + Pp.(debug 6 (lazy !^__LOC__)); let@ resource = WReq.welltyped loc resource in let@ bt = WBT.is_bt loc bt in let@ oarg_bt = oarg_bt loc resource in @@ -1131,7 +1131,7 @@ module WLRT = struct let welltyped loc lrt = let rec aux = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in function | Define ((s, it), ((loc, _) as info), lrt) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) @@ -1154,7 +1154,7 @@ module WLRT = struct return (Constraint (lc, info, lrt)) | I -> let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ () = match provable (LC.T (IT.bool_ false here)) with | `True -> @@ -1175,7 +1175,7 @@ module WRT = struct let pp = ReturnTypes.pp let welltyped loc rt = - Pp.(debug 6 (lazy !^__FUNCTION__)); + Pp.(debug 6 (lazy !^__LOC__)); pure (match rt with | RT.Computational ((name, bt), info, lrt) -> @@ -1209,7 +1209,7 @@ module WLAT = struct (lazy (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (LAT.pp i_pp at))); let rec aux = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in function | LAT.Define ((s, it), info, at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) @@ -1232,7 +1232,7 @@ module WLAT = struct return (LAT.Constraint (lc, info, at)) | LAT.I i -> let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ () = match provable (LC.T (IT.bool_ false here)) with | `True -> @@ -1294,8 +1294,8 @@ module WLArgs = struct : 'j Mu.arguments_l m = let rec aux = - let here = Locations.other __FUNCTION__ in - Pp.(debug 6 (lazy !^__FUNCTION__)); + let here = Locations.other __LOC__ in + Pp.(debug 6 (lazy !^__LOC__)); function | Mu.Define ((s, it), ((loc, _) as info), at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) @@ -1318,7 +1318,7 @@ module WLArgs = struct return (Mu.Constraint (lc, info, at)) | Mu.I i -> let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ () = match provable (LC.T (IT.bool_ false here)) with | `True -> @@ -1343,7 +1343,7 @@ module WArgs = struct (Loc.t -> 'i -> 'j m) -> string -> Loc.t -> 'i Mu.arguments -> 'j Mu.arguments m = fun (i_welltyped : Loc.t -> 'i -> 'j m) kind loc (at : 'i Mu.arguments) -> - debug 6 (lazy !^__FUNCTION__); + debug 6 (lazy !^__LOC__); debug 12 (lazy @@ -2203,7 +2203,7 @@ module WProc = struct let welltyped : Loc.t -> _ Mu.args_and_body -> _ Mu.args_and_body m = fun (loc : Loc.t) (at : 'TY1 Mu.args_and_body) -> - Pp.(debug 6 (lazy !^__FUNCTION__)); + Pp.(debug 6 (lazy !^__LOC__)); WArgs.welltyped (fun loc (body, labels, rt) -> let@ rt = pure_and_no_initial_resources loc (WRT.welltyped loc rt) in @@ -2272,7 +2272,7 @@ module WRPD = struct ListM.fold_leftM (fun acc Def.Clause.{ loc; guard; packing_ft } -> let@ guard = WIT.check loc BT.Bool guard in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let negated_guards = List.map (fun clause -> IT.not_ clause.Def.Clause.guard here) acc in diff --git a/tests/cn/reverse.error.c.verify b/tests/cn/reverse.error.c.verify index 3689e7f3e..e2950369f 100644 --- a/tests/cn/reverse.error.c.verify +++ b/tests/cn/reverse.error.c.verify @@ -13,5 +13,5 @@ tests/cn/reverse.error.c:124:3: error: Missing resource for de-allocating ^~~~~~~~~ Resource needed: Block(&n3) which requires: Block(&&n3->head) - other location (Cn__ResourceInference.General.predicate_request) (arg head) + other location (File "backend/cn/lib/resourceInference.ml", line 220, characters 31-38) (arg head) State file: file:///tmp/state__reverse.error.c__main.html diff --git a/tests/cn/tree16/as_mutual_dt/tree16.c.verify b/tests/cn/tree16/as_mutual_dt/tree16.c.verify index dd5e9c2d0..25c6aab52 100644 --- a/tests/cn/tree16/as_mutual_dt/tree16.c.verify +++ b/tests/cn/tree16/as_mutual_dt/tree16.c.verify @@ -8,8 +8,8 @@ tests/cn/tree16/as_mutual_dt/tree16.c:111:19: warning: 'each' expects a 'u64', b tests/cn/tree16/as_mutual_dt/tree16.c:121:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) ^ -other location (Cn__Compile.UsingLoads.handle.load) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1568, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. -other location (Cn__Compile.UsingLoads.handle.load) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1568, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. [1/1]: lookup_rec -- pass diff --git a/tests/cn/tree16/as_partial_map/tree16.c.verify b/tests/cn/tree16/as_partial_map/tree16.c.verify index a07da7874..1c4ec7eaf 100644 --- a/tests/cn/tree16/as_partial_map/tree16.c.verify +++ b/tests/cn/tree16/as_partial_map/tree16.c.verify @@ -14,9 +14,9 @@ tests/cn/tree16/as_partial_map/tree16.c:137:19: warning: 'each' expects a 'u64', tests/cn/tree16/as_partial_map/tree16.c:146:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) ^ -other location (Cn__Compile.UsingLoads.handle.load) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1568, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. -other location (Cn__Compile.UsingLoads.handle.load) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1568, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. [1/2]: cn_get_num_nodes -- pass [2/2]: lookup_rec -- pass From 170e68b065fd87bf3d9a569e65c43734fbbf69a6 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Thu, 26 Dec 2024 01:00:46 +0000 Subject: [PATCH 125/148] CN: Reduce opens in explain.ml --- backend/cn/lib/explain.ml | 102 ++++++++++++++++++++------------------ 1 file changed, 53 insertions(+), 49 deletions(-) diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index f1a2e7ce4..6425863d5 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -1,14 +1,15 @@ -open Report +module Rp = Report +module BT = BaseTypes module IT = IndexTerms module Def = Definition module Req = Request +module Res = Resource module LF = Definition.Function module LAT = LogicalArgumentTypes +module LC = LogicalConstraints +module Loc = Locations module C = Context -open Request -open IndexTerms open Pp -open C (* perhaps somehow unify with above *) type action = @@ -66,11 +67,11 @@ module ITSet = struct end let subterms_without_bound_variables bindings = - fold_subterms + IT.fold_subterms ~bindings (fun bindings acc t -> let pats = List.map fst bindings in - let bound = List.concat_map bound_by_pattern pats in + let bound = List.concat_map IT.bound_by_pattern pats in let bound = Sym.Set.of_list (List.map fst bound) in if Sym.Set.(is_empty (inter bound (IT.free_vars t))) then ITSet.add t acc @@ -82,11 +83,11 @@ let subterms_without_bound_variables bindings = (** Simplify a constraint in the context of a model. *) let simp_constraint eval lct = let eval_to_bool it = - match eval it with Some (IT (Const (Bool b1), _, _)) -> Some b1 | _ -> None + match eval it with Some (IT.IT (Const (Bool b1), _, _)) -> Some b1 | _ -> None in let is b it = match eval_to_bool it with Some b1 -> Bool.equal b b1 | _ -> false in - let rec go (IT (term, bt, loc)) = - let mk x = IT (x, bt, loc) in + let rec go (IT.IT (term, bt, loc)) = + let mk x = IT.IT (x, bt, loc) in let ands xs = IT.and_ xs loc in let go1 t = ands (go t) in match term with @@ -114,7 +115,7 @@ let rec simp_resource eval r = let is_true = match ct with | LC.T ct -> - (match eval ct with Some (IT (Const (Bool b), _, _)) -> b | _ -> false) + (match eval ct with Some (IT.IT (Const (Bool b), _, _)) -> b | _ -> false) | _ -> false in if is_true then @@ -128,7 +129,7 @@ let rec simp_resource eval r = | I i -> I i -let state ctxt log model_with_q extras = +let state (ctxt : C.t) log model_with_q extras = let where = let cur_colour = !Cerb_colour.do_colour in Cerb_colour.do_colour := false; @@ -158,10 +159,10 @@ let state ctxt log model_with_q extras = (* | None -> parens !^"not evaluated" *) (* in *) let render_constraints c = - { original = LC.pp c; simplified = List.map LC.pp (simp_constraint evaluate c) } + Rp.{ original = LC.pp c; simplified = List.map LC.pp (simp_constraint evaluate c) } in let render_sympair p = - { original = Sym.pp (fst p); simplified = [ Sym.pp (fst p) ] } + Rp.{ original = Sym.pp (fst p); simplified = [ Sym.pp (fst p) ] } (*Symbols do not need simplification*) in let interesting, uninteresting = @@ -180,13 +181,13 @@ let state ctxt log model_with_q extras = let log_comb acc entry = match entry with | State ctxt -> - let _, _, ps = not_given_to_solver ctxt in + let _, _, ps = C.not_given_to_solver ctxt in List.append ps acc | Action _ -> acc in List.fold_left log_comb [] log in - let forall_constraints, funs, ctxt_preds = not_given_to_solver ctxt in + let forall_constraints, funs, ctxt_preds = C.not_given_to_solver ctxt in let preds = let pred_compare (s1, _) (s2, _) = Sym.compare s1 s2 in (*CHT TODO: deriving this would require changing a lot of files *) @@ -201,27 +202,27 @@ let state ctxt log model_with_q extras = let interesting_preds, uninteresting_preds = List.partition (fun (_, v) -> Def.is_interesting v) preds in - add_labeled - lab_interesting + Rp.add_labeled + Rp.lab_interesting (List.concat [ List.map render_sympair interesting_preds; List.map render_sympair interesting_funs; List.map render_constraints interesting_constraints ]) - (add_labeled - lab_uninteresting + (Rp.add_labeled + Rp.lab_uninteresting (List.concat [ List.map render_sympair uninteresting_preds; List.map render_sympair uninteresting_funs; List.map render_constraints uninteresting_constraints ]) - labeled_empty) + Rp.labeled_empty) in let terms = let variables = - let make s ls = sym_ (s, ls, Locations.other __LOC__) in + let make s ls = IT.sym_ (s, ls, Locations.other __LOC__) in let basetype_binding (s, (binding, _)) = - match binding with Value _ -> None | BaseType ls -> Some (make s ls) + match binding with C.Value _ -> None | BaseType ls -> Some (make s ls) in ITSet.of_list (List.map (fun (s, ls) -> make s ls) quantifier_counter_model @@ -232,7 +233,7 @@ let state ctxt log model_with_q extras = match extras.unproven_constraint with | Some (T lc) -> subterms_without_bound_variables [] lc | Some (Forall ((s, bt), lc)) -> - let binder = (Pat (PSym s, bt, Loc.other __LOC__), None) in + let binder = IT.(Pat (PSym s, bt, Loc.other __LOC__), None) in subterms_without_bound_variables [ binder ] lc | None -> ITSet.empty in @@ -241,7 +242,7 @@ let state ctxt log model_with_q extras = | Some (P ret) -> ITSet.bigunion_map (subterms_without_bound_variables []) (ret.pointer :: ret.iargs) | Some (Q ret) -> - let binder = (Pat (PSym (fst ret.q), snd ret.q, Loc.other __LOC__), None) in + let binder = IT.(Pat (PSym (fst ret.q), snd ret.q, Loc.other __LOC__), None) in ITSet.union (ITSet.bigunion_map (subterms_without_bound_variables []) @@ -259,7 +260,7 @@ let state ctxt log model_with_q extras = (fun it -> match evaluate it with | Some value when not (IT.equal value it) -> - Some (it, { term = IT.pp it; value = IT.pp value }) + Some (it, Rp.{ term = IT.pp it; value = IT.pp value }) | Some _ -> None | None -> None) (ITSet.elements subterms) @@ -270,52 +271,53 @@ let state ctxt log model_with_q extras = match IT.get_bt it with BT.Unit -> false | BT.Loc () -> false | _ -> true) filtered in - add_labeled - lab_interesting + Rp.add_labeled + Rp.lab_interesting (List.map snd interesting) - (add_labeled lab_uninteresting (List.map snd uninteresting) labeled_empty) + (Rp.add_labeled Rp.lab_uninteresting (List.map snd uninteresting) Rp.labeled_empty) in let constraints = - add_labeled - lab_interesting + Rp.add_labeled + Rp.lab_interesting (List.map render_constraints interesting) - (add_labeled - lab_uninteresting + (Rp.add_labeled + Rp.lab_uninteresting (List.map render_constraints uninteresting) - labeled_empty) + Rp.labeled_empty) in let resources = let same_res, diff_res = match extras.request with - | None -> ([], get_rs ctxt) - | Some req -> List.partition (fun (r, _) -> Req.same_name req r) (get_rs ctxt) + | None -> ([], C.get_rs ctxt) + | Some req -> List.partition (fun (r, _) -> Req.same_name req r) (C.get_rs ctxt) in let interesting_diff_res, uninteresting_diff_res = List.partition (fun (ret, _o) -> match ret with - | P ret when Req.equal_name ret.name Req.Predicate.alloc -> false + | Req.P ret when Req.equal_name ret.name Req.Predicate.alloc -> false | _ -> true) diff_res in let with_suff mb x = match mb with None -> x | Some d -> d ^^^ x in let pp_res mb_suff (rt, args) = - { original = with_suff mb_suff (Res.pp (rt, args)); - simplified = - [ with_suff mb_suff (Res.pp (Interval.Solver.simp_rt evaluate rt, args)) ] - } + Rp. + { original = with_suff mb_suff (Res.pp (rt, args)); + simplified = + [ with_suff mb_suff (Res.pp (Interval.Solver.simp_rt evaluate rt, args)) ] + } in let interesting = List.map (fun re -> pp_res (Some (parens !^"same type")) re) same_res @ List.map (pp_res None) interesting_diff_res in let uninteresting = List.map (pp_res None) uninteresting_diff_res in - add_labeled - lab_interesting + Rp.add_labeled + Rp.lab_interesting interesting - (add_labeled lab_uninteresting uninteresting labeled_empty) + (Rp.add_labeled Rp.lab_uninteresting uninteresting Rp.labeled_empty) in - { where; not_given_to_solver; terms; resources; constraints } + Rp.{ where; not_given_to_solver; terms; resources; constraints } let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extras) = @@ -350,10 +352,12 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra (match Req.get_name req with | Owned _ -> [] | PName pname -> - let doc_clause (_name, c) = - { cond = IT.pp c.Def.Clause.guard; - clause = LogicalArgumentTypes.pp IT.pp (simp_resource evaluate c.packing_ft) - } + let doc_clause (_name, (c : Def.Clause.t)) = + Rp. + { cond = IT.pp c.guard; + clause = + LogicalArgumentTypes.pp IT.pp (simp_resource evaluate c.packing_ft) + } in List.map doc_clause (relevant_predicate_clauses ctxt.global pname req)) in @@ -366,4 +370,4 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra | None -> None in Pp.html_escapes := prev; - { requested; unproven; predicate_hints; trace } + Rp.{ requested; unproven; predicate_hints; trace } From 74d48c646217cae96e2c85d6890627a58ea5740c Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Thu, 26 Dec 2024 01:26:10 +0000 Subject: [PATCH 126/148] CN: Add Context interface file --- backend/cn/lib/context.ml | 1 - backend/cn/lib/context.mli | 108 ++++++++++++++++++++++++++++ backend/cn/lib/resourceInference.ml | 2 +- backend/cn/lib/solver.mli | 2 +- backend/cn/lib/typing.ml | 7 +- backend/cn/lib/typing.mli | 2 +- 6 files changed, 116 insertions(+), 6 deletions(-) create mode 100644 backend/cn/lib/context.mli diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index 3bd243713..474780df5 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -3,7 +3,6 @@ open List module BT = BaseTypes module Res = Resource module LC = LogicalConstraints -module Loc = Locations module IntMap = Map.Make (Int) type l_info = Locations.t * Pp.document Lazy.t diff --git a/backend/cn/lib/context.mli b/backend/cn/lib/context.mli new file mode 100644 index 000000000..872442846 --- /dev/null +++ b/backend/cn/lib/context.mli @@ -0,0 +1,108 @@ +type l_info = Locations.t * Pp.document Lazy.t + +val pp_l_info : Pp.document -> l_info -> Pp.document + +type basetype_or_value = + | BaseType of BaseTypes.t + | Value of IndexTerms.t + +val bt_of : basetype_or_value -> BaseTypes.t + +val has_value : basetype_or_value -> bool + +type resource_history = + { last_written : Locations.t; + reason_written : string; + last_written_id : int; + last_read : Locations.t; + last_read_id : int + } + +type t = + { computational : (basetype_or_value * l_info) Sym.Map.t; + logical : (basetype_or_value * l_info) Sym.Map.t; + resources : (Resource.t * int) list * int; + resource_history : resource_history Map.Make(Int).t; + constraints : LogicalConstraints.Set.t; + global : Global.t; + where : Where.t + } + +val empty : t + +val get_rs : t -> Resource.t list + +val pp_basetype_or_value : basetype_or_value -> Pp.document + +val pp_variable_bindings : (basetype_or_value * 'a) Sym.Map.t -> Pp.document + +val pp_constraints : LogicalConstraints.Set.t -> Pp.document + +val pp : t -> Pp.document + +val bound_a : Sym.t -> t -> bool + +val bound_l : Sym.t -> t -> bool + +val bound : Sym.t -> t -> bool + +val get_a : Sym.t -> t -> basetype_or_value + +val get_l : Sym.t -> t -> basetype_or_value + +val add_a_binding : Sym.t -> basetype_or_value -> l_info -> t -> t + +val add_a : Sym.t -> BaseTypes.t -> l_info -> t -> t + +val add_a_value : Sym.t -> IndexTerms.t -> l_info -> t -> t + +val add_l_binding : Sym.t -> basetype_or_value -> l_info -> t -> t + +val add_l : Sym.t -> BaseTypes.t -> l_info -> t -> t + +val add_l_value : Sym.t -> IndexTerms.t -> l_info -> t -> t + +val remove_a : Sym.t -> t -> t + +val add_c : LogicalConstraints.Set.elt -> t -> t + +val modify_where : (Where.t -> Where.t) -> t -> t + +val pp_history : resource_history -> Pp.document + +val set_map_history : int -> 'a -> 'a Map.Make(Int).t -> 'a Map.Make(Int).t + +val set_history : int -> resource_history -> t -> t + +val add_r : Locations.t -> Resource.t -> t -> t + +val res_map_history : resource_history Map.Make(Int).t -> int -> resource_history + +val res_history : t -> int -> resource_history + +val res_read + : Locations.t -> + int -> + int * resource_history Map.Make(Int).t -> + int * resource_history Map.Make(Int).t + +val res_written + : Locations.t -> + int -> + string -> + int * resource_history Map.Make(Int).t -> + int * resource_history Map.Make(Int).t + +val clone_history + : int -> + int list -> + resource_history Map.Make(Int).t -> + resource_history Map.Make(Int).t + +val json : t -> Yojson.Safe.t + +val not_given_to_solver + : t -> + LogicalConstraints.t list + * (Sym.t * Definition.Function.t) list + * (Sym.t * Definition.Predicate.t) list diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 4d02ef98b..785514c14 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -141,7 +141,7 @@ module General = struct | `False -> let@ model = model () in let@ all_cs = get_cs () in - let () = assert (not (Context.LC.Set.mem c all_cs)) in + let () = assert (not (LC.Set.mem c all_cs)) in debug_constraint_failure_diagnostics 6 model simp_ctxt c; let@ () = Diagnostics.investigate model c in fail (fun ctxt -> diff --git a/backend/cn/lib/solver.mli b/backend/cn/lib/solver.mli index 45f907469..6a3fdf06b 100644 --- a/backend/cn/lib/solver.mli +++ b/backend/cn/lib/solver.mli @@ -41,7 +41,7 @@ val provable : loc:Locations.t -> solver:solver -> global:Global.t -> - assumptions:Context.LC.Set.t -> + assumptions:LogicalConstraints.Set.t -> simp_ctxt:Simplify.simp_ctxt -> LogicalConstraints.t -> [> `True | `False ] diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index df9cd162a..b61011e04 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -1,7 +1,10 @@ -open Context +module BT = BaseTypes +module Res = Resource +module Req = Request +module LC = LogicalConstraints +module Loc = Locations module IT = IndexTerms module ITSet = Set.Make (IT) -open TypeErrors type solver = Solver.solver diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index b46997b96..409aea56c 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -34,7 +34,7 @@ val print_with_ctxt : (Context.t -> unit) -> unit m val get_global : unit -> Global.t m -val get_cs : unit -> Context.LC.Set.t m +val get_cs : unit -> LogicalConstraints.Set.t m val simp_ctxt : unit -> Simplify.simp_ctxt m From c90405f1a69c3118fd050eb5cddc7408975165ee Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Thu, 26 Dec 2024 02:18:43 +0000 Subject: [PATCH 127/148] CN: Add TypeError interface file --- backend/cn/bin/main.ml | 2 +- backend/cn/lib/builtins.ml | 28 +- backend/cn/lib/check.ml | 3 +- backend/cn/lib/compile.ml | 9 +- backend/cn/lib/lemmata.ml | 2 +- backend/cn/lib/resourceInference.ml | 8 +- backend/cn/lib/resourceInference.mli | 2 +- backend/cn/lib/typeErrors.ml | 168 ++++++------ backend/cn/lib/typeErrors.mli | 246 ++++++++++++++++++ backend/cn/lib/wellTyped.ml | 5 +- tests/cn/tree16/as_mutual_dt/tree16.c.verify | 4 +- .../cn/tree16/as_partial_map/tree16.c.verify | 4 +- 12 files changed, 365 insertions(+), 116 deletions(-) create mode 100644 backend/cn/lib/typeErrors.mli diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index f9b9fd508..08d9946ca 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -479,7 +479,7 @@ let run_tests Pp.print_level := print_level; Check.skip_and_only := (opt_comma_split skip, opt_comma_split only); Sym.executable_spec_enabled := true; - let handle_error (e : TypeErrors.type_error) = + let handle_error (e : TypeErrors.t) = let report = TypeErrors.pp_message e.msg in Pp.error e.loc report.short (Option.to_list report.descr); match e.msg with TypeErrors.Unsupported _ -> exit 2 | _ -> exit 1 diff --git a/backend/cn/lib/builtins.ml b/backend/cn/lib/builtins.ml index 6d6af1ebf..e6e775c77 100644 --- a/backend/cn/lib/builtins.ml +++ b/backend/cn/lib/builtins.ml @@ -1,9 +1,5 @@ module SBT = BaseTypes.Surface open Resultat - -open Effectful.Make (Resultat) - -open TypeErrors open IndexTerms (* builtin function symbols *) @@ -51,7 +47,7 @@ let min_bits_def (sign, n) = let name = "MIN" ^ letter ^ Int.to_string n in ( name, Sym.fresh_named name, - mk_arg0 (fun loc -> IT.Surface.inj @@ num_lit_ num (BT.Bits (sign, n)) loc) ) + mk_arg0 (fun loc -> Surface.inj @@ num_lit_ num (BT.Bits (sign, n)) loc) ) let max_bits_def (sign, n) = @@ -63,7 +59,7 @@ let max_bits_def (sign, n) = let name = "MAX" ^ letter ^ Int.to_string n in ( name, Sym.fresh_named name, - mk_arg0 (fun loc -> IT.Surface.inj @@ num_lit_ num (BT.Bits (sign, n)) loc) ) + mk_arg0 (fun loc -> Surface.inj @@ num_lit_ num (BT.Bits (sign, n)) loc) ) let mul_uf_def = ("mul_uf", Sym.fresh_named "mul_uf", mk_arg2 mul_no_smt_) @@ -122,15 +118,13 @@ let array_to_list_def = ( "array_to_list", Sym.fresh_named "array_to_list", mk_arg3_err (fun (arr, i, len) loc -> - match SBT.is_map_bt (IT.get_bt arr) with + match SBT.is_map_bt (get_bt arr) with | None -> let reason = "map/array operation" in let expected = "map/array" in fail { loc; - msg = - Illtyped_it - { it = IT.pp arr; has = SBT.pp (IT.get_bt arr); expected; reason } + msg = Illtyped_it { it = pp arr; has = SBT.pp (get_bt arr); expected; reason } } | Some (_, bt) -> return (array_to_list_ (arr, i, len) bt loc)) ) @@ -138,37 +132,35 @@ let array_to_list_def = let is_null_def = ( "is_null", Sym.fresh_named "is_null", - mk_arg1 IT.(fun p loc -> Surface.inj (eq_ (Surface.proj p, null_ loc) loc)) ) + mk_arg1 (fun p loc -> Surface.inj (eq_ (Surface.proj p, null_ loc) loc)) ) let has_alloc_id_def = ( "has_alloc_id", Sym.fresh_named "has_alloc_id", - mk_arg1 IT.(fun p loc -> Surface.inj @@ hasAllocId_ (Surface.proj p) loc) ) + mk_arg1 (fun p loc -> Surface.inj @@ hasAllocId_ (Surface.proj p) loc) ) let ptr_eq_def = ( "ptr_eq", Sym.fresh_named "ptr_eq", mk_arg2 (fun (p1, p2) loc -> - IT.(Surface.inj @@ eq_ (Surface.proj p1, Surface.proj p2) loc)) ) + Surface.inj @@ eq_ (Surface.proj p1, Surface.proj p2) loc) ) let prov_eq_def = ( "prov_eq", Sym.fresh_named "prov_eq", mk_arg2 (fun (p1, p2) loc -> - IT.( - Surface.inj - @@ eq_ (allocId_ (Surface.proj p1) loc, allocId_ (Surface.proj p2) loc) loc)) ) + Surface.inj + @@ eq_ (allocId_ (Surface.proj p1) loc, allocId_ (Surface.proj p2) loc) loc) ) let addr_eq_def = ( "addr_eq", Sym.fresh_named "addr_eq", mk_arg2 (fun (p1, p2) loc -> - IT.( - Surface.inj @@ eq_ (addr_ (Surface.proj p1) loc, addr_ (Surface.proj p2) loc) loc)) + Surface.inj @@ eq_ (addr_ (Surface.proj p1) loc, addr_ (Surface.proj p2) loc) loc) ) diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 657333970..ccc01f38e 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -2,6 +2,7 @@ module CF = Cerb_frontend module IT = IndexTerms module BT = BaseTypes module LRT = LogicalReturnTypes +module Req = Request module RT = ReturnTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes @@ -1008,7 +1009,7 @@ module Spine : sig val calltype_lt : Loc.t -> BT.t Mu.pexpr list -> - AT.lt * label_kind -> + AT.lt * Where.label -> (False.t -> unit m) -> unit m diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index abbdaaa9f..988b14585 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -375,11 +375,14 @@ module E = struct type 'a m = | Done of 'a | Error of TypeErrors.t - | ScopeExists of Loc.t * evaluation_scope * (bool -> 'a m) + | ScopeExists of Locations.t * evaluation_scope * (bool -> 'a m) | Value_of_c_variable of - Loc.t * Sym.t * evaluation_scope option * (IT.Surface.t option -> 'a m) + Locations.t * Sym.t * evaluation_scope option * (IT.Surface.t option -> 'a m) | Deref of - Loc.t * IT.Surface.t * evaluation_scope option * (IT.Surface.t option -> 'a m) + Locations.t + * IT.Surface.t + * evaluation_scope option + * (IT.Surface.t option -> 'a m) let return x = Done x diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index 3526ce5a6..272c6701c 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -32,7 +32,7 @@ module PrevDefs = struct { present : Sym.t list StringListMap.t; defs : Pp.document list IntMap.t; dt_params : (IT.t * Id.t * Sym.t) list; - failures : TypeErrors.type_error list + failures : TypeErrors.t list } let init_t = diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 785514c14..07e11f63a 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -47,7 +47,7 @@ module General = struct value : IT.t } - type uiinfo = TypeErrors.situation * TypeErrors.request_chain + type uiinfo = TypeErrors.situation * TypeErrors.RequestChain.t type case = | One of one @@ -105,7 +105,7 @@ module General = struct let resource = Simplify.Request.simp simp_ctxt resource in let situation, request_chain = uiinfo in let step = - TypeErrors. + TypeErrors.RequestChain. { resource; loc = Some (fst info); reason = Some ("arg " ^ Sym.pp_string s) } in let request_chain = step :: request_chain in @@ -469,7 +469,7 @@ module Special = struct let predicate_request loc situation (request, oinfo) = let requests = - [ TypeErrors. + [ TypeErrors.RequestChain. { resource = P request; loc = Option.map fst oinfo; reason = Option.map snd oinfo @@ -546,7 +546,7 @@ module Special = struct let qpredicate_request loc situation (request, oinfo) = let requests = - [ TypeErrors. + [ TypeErrors.RequestChain. { resource = Q request; loc = Option.map fst oinfo; reason = Option.map snd oinfo diff --git a/backend/cn/lib/resourceInference.mli b/backend/cn/lib/resourceInference.mli index e2ac6dba0..8b6829d53 100644 --- a/backend/cn/lib/resourceInference.mli +++ b/backend/cn/lib/resourceInference.mli @@ -6,7 +6,7 @@ val debug_constraint_failure_diagnostics unit module General : sig - type uiinfo = TypeErrors.situation * TypeErrors.request_chain + type uiinfo = TypeErrors.situation * TypeErrors.RequestChain.t val ftyp_args_request_step : ([ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> 'a -> 'a) -> diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index f344982fb..bcaac62f2 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -1,13 +1,10 @@ -open Explain -open Pp -open Locations -module BT = BaseTypes module IT = IndexTerms module CF = Cerb_frontend module Loc = Locations module Res = Resource module LC = LogicalConstraints module Req = Request +open Pp type label_kind = Where.label @@ -87,13 +84,32 @@ let for_situation = function | Subtyping -> !^"for returning") -type request_chain_elem = - { resource : Req.t; - loc : Locations.t option; - reason : string option - } +module RequestChain = struct + type elem = + { resource : Req.t; + loc : Locations.t option; + reason : string option + } + + type t = elem list -type request_chain = request_chain_elem list + let pp requests = + let pp_req req = + let doc = Req.pp req.resource in + let doc = + match req.loc with + | None -> doc + | Some loc -> + doc ^^ hardline ^^ !^" " ^^ !^(fst (Locations.head_pos_of_location loc)) + in + match req.reason with None -> doc | Some str -> doc ^^^ parens !^str + in + let rec loop req = function + | [] -> !^"Resource needed:" ^^^ pp_req req + | req2 :: reqs -> loop req2 reqs ^^ hardline ^^ !^" which requires:" ^^^ pp_req req + in + match requests with [] -> None | req :: reqs -> Some (loop req reqs) +end type message = | Unknown_variable of Sym.t @@ -119,20 +135,20 @@ type message = } | Missing_member of Id.t | Missing_resource of - { requests : request_chain; + { requests : RequestChain.t; situation : situation; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Merging_multiple_arrays of - { requests : request_chain; + { requests : RequestChain.t; situation : situation; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Unused_resource of { resource : Res.t; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Number_members of @@ -156,8 +172,8 @@ type message = expect : document } | Illtyped_it of - { it : Pp.document; - has : Pp.document; (* 'expected' and 'has' as in Kayvan's Core type checker *) + { it : document; + has : document; (* 'expected' and 'has' as in Kayvan's Core type checker *) expected : string; reason : string } @@ -176,99 +192,81 @@ type message = { ct : Sctypes.t; location : IT.t; value : IT.t; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Int_unrepresentable of { value : IT.t; ict : Sctypes.t; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Unproven_constraint of { constr : LC.t; - requests : request_chain; - info : info; - ctxt : Context.t * log; + requests : RequestChain.t; + info : Locations.info; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Undefined_behaviour of { ub : CF.Undefined.undefined_behaviour; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Needs_alloc_id of { ptr : IT.t; ub : CF.Undefined.undefined_behaviour; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Alloc_out_of_bounds of { term : IT.t; constr : IT.t; ub : CF.Undefined.undefined_behaviour; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Allocation_not_live of { reason : [ `Copy_alloc_id | `Ptr_cmp | `Ptr_diff | `ISO_array_shift | `ISO_member_shift ]; ptr : IT.t; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model_constr : (Solver.model_with_q * IT.t) option } (* | Implementation_defined_behaviour of document * state_report *) | Unspecified of CF.Ctype.ctype | StaticError of { err : string; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } - | Generic of Pp.document + | Generic of document | Generic_with_model of - { err : Pp.document; + { err : document; model : Solver.model_with_q; - ctxt : Context.t * log + ctxt : Context.t * Explain.log } - | Unsupported of Pp.document + | Unsupported of document | Parser of Cerb_frontend.Errors.cparser_cause | Empty_pattern - | Missing_pattern of Pp.document - | Redundant_pattern of Pp.document + | Missing_pattern of document + | Redundant_pattern of document | Duplicate_pattern | Empty_provenance - | Inconsistent_assumptions of string * (Context.t * log) + | Inconsistent_assumptions of string * (Context.t * Explain.log) | Byte_conv_needs_owned -type type_error = +type t = { loc : Locations.t; msg : message } type report = - { short : Pp.document; - descr : Pp.document option; + { short : document; + descr : document option; state : Report.report option } -let request_chain_description requests = - let pp_req req = - let doc = Req.pp req.resource in - let doc = - match req.loc with - | None -> doc - | Some loc -> - doc ^^ hardline ^^ !^" " ^^ !^(fst (Locations.head_pos_of_location loc)) - in - match req.reason with None -> doc | Some str -> doc ^^^ parens !^str - in - let rec loop req = function - | [] -> !^"Resource needed:" ^^^ pp_req req - | req2 :: reqs -> loop req2 reqs ^^ hardline ^^ !^" which requires:" ^^^ pp_req req - in - match requests with [] -> None | req :: reqs -> Some (loop req reqs) - - let pp_message te = match te with | Unknown_variable s -> @@ -306,7 +304,7 @@ let pp_message te = { short; descr; state = None } | Unexpected_member (expected, member) -> let short = !^"Unexpected member" ^^^ Id.pp member in - let descr = !^"the struct only has members" ^^^ Pp.list Id.pp expected in + let descr = !^"the struct only has members" ^^^ list Id.pp expected in { short; descr = Some descr; state = None } | Unknown_lemma sym -> let short = !^"Unknown lemma" ^^^ squotes (Sym.pp sym) in @@ -319,11 +317,11 @@ let pp_message te = let short = !^"Non-pointer first input argument" in let descr = !^"the first input argument of predicate" - ^^^ Pp.squotes (Request.pp_name pname) + ^^^ squotes (Request.pp_name pname) ^^^ !^"must have type" - ^^^ Pp.squotes BaseTypes.(pp (Loc ())) + ^^^ squotes BaseTypes.(pp (Loc ())) ^^^ !^"but was found with type" - ^^^ Pp.squotes BaseTypes.(pp found_bty) + ^^^ squotes BaseTypes.(pp found_bty) in { short; descr = Some descr; state = None } | Missing_member m -> @@ -331,11 +329,13 @@ let pp_message te = { short; descr = None; state = None } | Missing_resource { requests; situation; ctxt; model } -> let short = !^"Missing resource" ^^^ for_situation situation in - let descr = request_chain_description requests in + let descr = RequestChain.pp requests in let orequest = - Option.map (fun r -> r.resource) (List.nth_opt (List.rev requests) 0) + Option.map + (fun (r : RequestChain.elem) -> r.RequestChain.resource) + (List.nth_opt (List.rev requests) 0) in - let state = trace ctxt model Explain.{ no_ex with request = orequest } in + let state = Explain.trace ctxt model Explain.{ no_ex with request = orequest } in { short; descr; state = Some state } | Merging_multiple_arrays { requests; situation; ctxt; model } -> let short = @@ -344,16 +344,16 @@ let pp_message te = ^^ dot ^^^ !^"It requires merging multiple arrays." in - let descr = request_chain_description requests in + let descr = RequestChain.pp requests in let orequest = - Option.map (fun r -> r.resource) (List.nth_opt (List.rev requests) 0) + Option.map (fun r -> r.RequestChain.resource) (List.nth_opt (List.rev requests) 0) in - let state = trace ctxt model Explain.{ no_ex with request = orequest } in + let state = Explain.trace ctxt model Explain.{ no_ex with request = orequest } in { short; descr; state = Some state } | Unused_resource { resource; ctxt; model } -> let resource = Res.pp resource in let short = !^"Left-over unused resource" ^^^ squotes resource in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in { short; descr = None; state = Some state } | Number_members { has; expect } -> let short = !^"Wrong number of struct members" in @@ -461,7 +461,7 @@ let pp_message te = let short = !^"Write value not representable at type" ^^^ Sctypes.pp ct in let location = IT.pp location in let value = IT.pp value in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in let descr = !^"Location" ^^ colon ^^^ location ^^ comma ^^^ !^"value" ^^ colon ^^^ value ^^ dot in @@ -470,12 +470,12 @@ let pp_message te = let short = !^"integer value not representable at type" ^^^ Sctypes.pp ict in let value = IT.pp value in let descr = !^"Value" ^^ colon ^^^ value in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in { short; descr = Some descr; state = Some state } | Unproven_constraint { constr; requests; info; ctxt; model } -> let short = !^"Unprovable constraint" in let state = - trace ctxt model Explain.{ no_ex with unproven_constraint = Some constr } + Explain.trace ctxt model Explain.{ no_ex with unproven_constraint = Some constr } in let descr = let spec_loc, odescr = info in @@ -485,14 +485,14 @@ let pp_message te = | None -> !^"Constraint from" ^^^ !^head ^/^ !^pos | Some descr -> !^"Constraint from" ^^^ !^descr ^^^ !^head ^/^ !^pos in - match request_chain_description requests with + match RequestChain.pp requests with | Some doc2 -> doc ^^ hardline ^^ doc2 | None -> doc in { short; descr = Some descr; state = Some state } | Undefined_behaviour { ub; ctxt; model } -> let short = !^"Undefined behaviour" in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in let descr = match CF.Undefined.std_of_undefined_behaviour ub with | Some stdref -> !^(CF.Undefined.ub_short_string ub) ^^^ parens !^stdref @@ -501,7 +501,7 @@ let pp_message te = { short; descr = Some descr; state = Some state } | Needs_alloc_id { ptr; ub; ctxt; model } -> let short = !^"Pointer " ^^ bquotes (IT.pp ptr) ^^ !^" needs allocation ID" in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in let descr = match CF.Undefined.std_of_undefined_behaviour ub with | Some stdref -> !^(CF.Undefined.ub_short_string ub) ^^^ parens !^stdref @@ -511,7 +511,10 @@ let pp_message te = | Alloc_out_of_bounds { constr; term; ub; ctxt; model } -> let short = bquotes (IT.pp term) ^^ !^" out of bounds" in let state = - trace ctxt model Explain.{ no_ex with unproven_constraint = Some (LC.T constr) } + Explain.trace + ctxt + model + Explain.{ no_ex with unproven_constraint = Some (LC.T constr) } in let descr = match CF.Undefined.std_of_undefined_behaviour ub with @@ -540,7 +543,10 @@ let pp_message te = let state = Option.map (fun (model, constr) -> - trace ctxt model Explain.{ no_ex with unproven_constraint = Some (LC.T constr) }) + Explain.trace + ctxt + model + Explain.{ no_ex with unproven_constraint = Some (LC.T constr) }) model_constr in let descr = !^"Need an Alloc or Owned in context with same allocation id" in @@ -554,7 +560,7 @@ let pp_message te = { short; descr = None; state = None } | StaticError { err; ctxt; model } -> let short = !^"Static error" in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in let descr = !^err in { short; descr = Some descr; state = Some state } | Generic err -> @@ -562,7 +568,7 @@ let pp_message te = { short; descr = None; state = None } | Generic_with_model { err; model; ctxt } -> let short = err in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in { short; descr = None; state = Some state } | Unsupported err -> let short = err in @@ -605,15 +611,13 @@ let pp_message te = { short; descr; state = None } | Inconsistent_assumptions (kind, ctxt_log) -> let short = !^kind ^^ !^" makes inconsistent assumptions" in - let state = Some (trace ctxt_log (Solver.empty_model, []) Explain.no_ex) in + let state = Some (Explain.trace ctxt_log (Solver.empty_model, []) Explain.no_ex) in { short; descr = None; state } | Byte_conv_needs_owned -> let short = !^"byte conversion only supports Owned/Block" in { short; descr = None; state = None } -type t = type_error - (** Convert a possibly-relative filepath into an absolute one. *) let canonicalize (path : string) : string = if Filename.is_relative path then ( @@ -713,7 +717,7 @@ let report_pretty [ state_msg ] | None -> [] in - Pp.error loc report.short (Option.to_list report.descr @ consider) + error loc report.short (Option.to_list report.descr @ consider) (* stealing some logic from pp_errors *) @@ -740,12 +744,12 @@ let report_json | None -> (`Null, `Null) in let descr = - match report.descr with None -> `Null | Some descr -> `String (Pp.plain descr) + match report.descr with None -> `Null | Some descr -> `String (plain descr) in let json = `Assoc [ ("loc", Loc.json_loc loc); - ("short", `String (Pp.plain report.short)); + ("short", `String (plain report.short)); ("descr", descr); ("state", state_error_file); ("report", report_file) diff --git a/backend/cn/lib/typeErrors.mli b/backend/cn/lib/typeErrors.mli new file mode 100644 index 000000000..a5c1b9a3e --- /dev/null +++ b/backend/cn/lib/typeErrors.mli @@ -0,0 +1,246 @@ +(** TODO Switch to this structure: https://rustc-dev-guide.rust-lang.org/diagnostics.html#diagnostic-structure *) + +(** TODO Cleanly factor out all pretty printing from all error gathering. + Pp.document, string to actual types (including polymorphic variants if need be) *) + +type access = + | Load + | Store + | Deref + | Kill + | Free + | To_bytes + | From_bytes + +type call_situation = + | FunctionCall of Sym.t + | LemmaApplication of Sym.t + | LabelCall of Where.label + | Subtyping + +val call_prefix : call_situation -> string + +type situation = + | Access of access + | Call of call_situation + +(** TODO move *) +val call_situation : call_situation -> Pp.document + +(** TODO move *) +val checking_situation : situation -> Pp.document + +(** TODO move *) +val for_access : access -> Pp.document + +(** TODO move *) +val for_situation : situation -> Pp.document + +module RequestChain : sig + type elem = + { resource : Request.t; + loc : Cerb_location.t option; + reason : string option (** TODO replace with an actual type *) + } + + type t = elem list + + (** TODO move *) + val pp : t -> Pp.document option +end + +type message = + | Unknown_variable of Sym.t + | Unknown_function of Sym.t + | Unknown_struct of Sym.t + | Unknown_datatype of Sym.t + | Unknown_datatype_constr of Sym.t + | Unknown_resource_predicate of + { id : Sym.t; + logical : bool + } + | Unknown_logical_function of + { id : Sym.t; + resource : bool + } + | Unexpected_member of Id.t list * Id.t + | Unknown_lemma of Sym.t + | First_iarg_missing + | First_iarg_not_pointer of + { pname : Request.name; + found_bty : BaseTypes.t + } + | Missing_member of Id.t + | Missing_resource of + { requests : RequestChain.t; + situation : situation; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Merging_multiple_arrays of + { requests : RequestChain.t; + situation : situation; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Unused_resource of + { resource : Resource.t; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Number_members of + { has : int; + expect : int + } + | Number_arguments of + { has : int; + expect : int + } + | Number_input_arguments of + { has : int; + expect : int + } + | Number_output_arguments of + { has : int; + expect : int + } + | Mismatch of + { has : Pp.document; (** TODO replace with an actual type *) + expect : Pp.document (** TODO replace with an acutal type *) + } + | Illtyped_it of + { it : Pp.document; (** TODO replace with an actual type *) + has : Pp.document; (* TODO replace with an actual type *) + expected : string; (** TODO replace with an actual type *) + reason : string (** TODO replace with an actual type *) + } + | Illtyped_binary_it of + { left : IndexTerms.Surface.t; + right : IndexTerms.Surface.t; + binop : Cerb_frontend.Cn.cn_binop + } + | NIA of + { it : IndexTerms.t; + hint : string (** TODO replace with an actual type *) + } + | TooBigExponent : { it : IndexTerms.t } -> message + | NegativeExponent : { it : IndexTerms.t } -> message + | Write_value_unrepresentable of + { ct : Sctypes.t; + location : IndexTerms.t; + value : IndexTerms.t; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Int_unrepresentable of + { value : IndexTerms.t; + ict : Sctypes.t; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Unproven_constraint of + { constr : LogicalConstraints.t; + requests : RequestChain.t; + info : Locations.info; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Undefined_behaviour of + { ub : Cerb_frontend.Undefined.undefined_behaviour; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Needs_alloc_id of + { ptr : IndexTerms.t; + ub : Cerb_frontend.Undefined.undefined_behaviour; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Alloc_out_of_bounds of + { term : IndexTerms.t; + constr : IndexTerms.t; + ub : Cerb_frontend.Undefined.undefined_behaviour; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Allocation_not_live of + { reason : + [ `Copy_alloc_id | `ISO_array_shift | `ISO_member_shift | `Ptr_cmp | `Ptr_diff ]; + ptr : IndexTerms.t; + ctxt : Context.t * Explain.log; + model_constr : (Solver.model_with_q * IndexTerms.t) option + } + | Unspecified of Cerb_frontend.Ctype.ctype + | StaticError of + { err : string; (** TODO replace with an actual type *) + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Generic of Pp.document (** TODO delete this *) + | Generic_with_model of + { err : Pp.document; (** TODO delete this too *) + model : Solver.model_with_q; + ctxt : Context.t * Explain.log + } + | Unsupported of Pp.document (** TODO add source location *) + | Parser of Cerb_frontend.Errors.cparser_cause + | Empty_pattern + | Missing_pattern of Pp.document (** TODO delete this *) + | Redundant_pattern of Pp.document (** TODO delete this *) + | Duplicate_pattern + | Empty_provenance + | Inconsistent_assumptions of string * (Context.t * Explain.log) + (** TODO replace string with an actual type *) + | Byte_conv_needs_owned + +type t = + { loc : Locations.t; + msg : message + } + +(** TODO move *) +type report = + { short : Pp.document; + descr : Pp.document option; + state : Report.report option (** Why is this here? *) + } + +(** TODO move *) +val pp_message : message -> report + +(** TODO move *) +val canonicalize : string -> string + +(** TODO move *) +val mk_output_dir : string option -> string + +(** TODO move *) +val located_file_name + : ?fn_name:string -> + dir:string -> + name:string -> + ext:string -> + Cerb_location.t -> + string + +(** TODO move *) +val mk_state_file_name : ?fn_name:string -> string -> Cerb_location.t -> string + +(** TODO move *) +val mk_report_file_name : ?fn_name:string -> string -> Cerb_location.t -> string + +(** TODO move *) +val report_pretty + : ?output_dir:string -> + ?fn_name:string -> + ?serialize_json:bool -> + t -> + unit + +(** TODO move *) +val report_json + : ?output_dir:string -> + ?fn_name:string -> + ?serialize_json:bool -> + t -> + unit diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index a37af727f..8570ca452 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -1,5 +1,8 @@ module CF = Cerb_frontend module BT = BaseTypes +module IT = IndexTerms +module Loc = Locations +module LC = LogicalConstraints module TE = TypeErrors module Res = Resource module Req = Request @@ -1373,7 +1376,7 @@ module BaseTyping = struct module AT = ArgumentTypes open BT - type label_context = (AT.lt * label_kind * Locations.t) Sym.Map.t + type label_context = (AT.lt * Where.label * Locations.t) Sym.Map.t let check_against_core_bt loc msg2 cbt bt = Typing.embed_resultat diff --git a/tests/cn/tree16/as_mutual_dt/tree16.c.verify b/tests/cn/tree16/as_mutual_dt/tree16.c.verify index 25c6aab52..20653f7a8 100644 --- a/tests/cn/tree16/as_mutual_dt/tree16.c.verify +++ b/tests/cn/tree16/as_mutual_dt/tree16.c.verify @@ -8,8 +8,8 @@ tests/cn/tree16/as_mutual_dt/tree16.c:111:19: warning: 'each' expects a 'u64', b tests/cn/tree16/as_mutual_dt/tree16.c:121:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) ^ -other location (File "backend/cn/lib/compile.ml", line 1568, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1571, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. -other location (File "backend/cn/lib/compile.ml", line 1568, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1571, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. [1/1]: lookup_rec -- pass diff --git a/tests/cn/tree16/as_partial_map/tree16.c.verify b/tests/cn/tree16/as_partial_map/tree16.c.verify index 1c4ec7eaf..01ac506e8 100644 --- a/tests/cn/tree16/as_partial_map/tree16.c.verify +++ b/tests/cn/tree16/as_partial_map/tree16.c.verify @@ -14,9 +14,9 @@ tests/cn/tree16/as_partial_map/tree16.c:137:19: warning: 'each' expects a 'u64', tests/cn/tree16/as_partial_map/tree16.c:146:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) ^ -other location (File "backend/cn/lib/compile.ml", line 1568, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1571, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. -other location (File "backend/cn/lib/compile.ml", line 1568, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1571, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. [1/2]: cn_get_num_nodes -- pass [2/2]: lookup_rec -- pass From 140db7a8af18caf1934a99e5736afea3496bfbbb Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Thu, 26 Dec 2024 02:26:36 +0000 Subject: [PATCH 128/148] CN: Rename Resultat to Or_TypeError --- backend/cn/bin/main.ml | 10 ++--- backend/cn/lib/builtins.ml | 2 +- backend/cn/lib/check.ml | 6 +-- backend/cn/lib/compile.ml | 36 +++++++-------- backend/cn/lib/coreTypeChecks.ml | 2 +- backend/cn/lib/core_to_mucore.ml | 6 +-- backend/cn/lib/core_to_mucore.mli | 2 +- backend/cn/lib/effectful.ml | 45 +++++++++---------- backend/cn/lib/lemmata.ml | 24 +++++----- .../cn/lib/{resultat.ml => or_TypeError.ml} | 2 - backend/cn/lib/parse.ml | 4 +- backend/cn/lib/typing.ml | 10 ++--- backend/cn/lib/typing.mli | 4 +- backend/cn/lib/wellTyped.ml | 5 ++- 14 files changed, 78 insertions(+), 80 deletions(-) rename backend/cn/lib/{resultat.ml => or_TypeError.ml} (93%) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 08d9946ca..a80720458 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -136,7 +136,7 @@ let with_well_formedness_check ail_prog:CF.GenTypes.genTypeCategory A.ail_program -> statement_locs:Cerb_location.t CStatements.LocMap.t -> paused:_ Typing.pause -> - unit Resultat.t) + unit Or_TypeError.t) = check_input_file filename; let prog, (markers_env, ail_prog), statement_locs = @@ -157,7 +157,7 @@ let with_well_formedness_check | _ -> None); try let result = - let open Resultat in + let open Or_TypeError in let@ prog5 = Core_to_mucore.normalise_file ~inherit_loc:(not no_inherit_loc) @@ -250,7 +250,7 @@ let well_formed ~no_inherit_loc ~magic_comment_char_dollar ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) - ~f:(fun ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused:_ -> Resultat.return ()) + ~f:(fun ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused:_ -> Or_TypeError.return ()) let verify @@ -429,7 +429,7 @@ let generate_executable_specs statement_locs with | e -> handle_error_with_user_guidance ~label:"CN-Exec" e); - Resultat.return ()) + Or_TypeError.return ()) ()) @@ -564,7 +564,7 @@ let run_tests if not dont_run then Unix.execv (Filename.concat output_dir "run_tests.sh") (Array.of_list [])) (); - Resultat.return ()) + Or_TypeError.return ()) open Cmdliner diff --git a/backend/cn/lib/builtins.ml b/backend/cn/lib/builtins.ml index e6e775c77..0ccf6ca3e 100644 --- a/backend/cn/lib/builtins.ml +++ b/backend/cn/lib/builtins.ml @@ -1,5 +1,5 @@ module SBT = BaseTypes.Surface -open Resultat +open Or_TypeError open IndexTerms (* builtin function symbols *) diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index ccc01f38e..e1a561f63 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -412,9 +412,9 @@ let check_conv_int loc ~expect ct arg = let check_against_core_bt loc msg2 cbt bt = - Typing.embed_resultat + Typing.lift (CoreTypeChecks.check_against_core_bt - (fun msg -> Resultat.fail { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) + (fun msg -> Or_TypeError.fail { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) cbt bt) @@ -2678,7 +2678,7 @@ let time_check_c_functions (checked : c_function list) : (string * TypeErrors.t) let generate_lemmas lemmata o_lemma_mode = let@ global = get_global () in match o_lemma_mode with - | Some mode -> embed_resultat (Lemmata.generate global mode lemmata) + | Some mode -> lift (Lemmata.generate global mode lemmata) | None -> return () (* TODO: diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 988b14585..76ddb603b 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -34,8 +34,8 @@ type env = datatypes : BaseTypes.dt_info Sym.Map.t; datatype_constrs : BaseTypes.constr_info Sym.Map.t; tagDefs : (Cerb_frontend.Symbol.sym, Mu.tag_definition) Pmap.map; - fetch_enum_expr : Locations.t -> Sym.t -> unit CF.AilSyntax.expression Resultat.t; - fetch_typedef : Locations.t -> Sym.t -> CF.Ctype.ctype Resultat.t + fetch_enum_expr : Locations.t -> Sym.t -> unit CF.AilSyntax.expression Or_TypeError.t; + fetch_typedef : Locations.t -> Sym.t -> CF.Ctype.ctype Or_TypeError.t } let init_env tagDefs fetch_enum_expr fetch_typedef = @@ -258,9 +258,9 @@ let register_cn_predicates env (defs : cn_predicate list) = List.fold_left aux env defs -open Resultat +open Or_TypeError -open Effectful.Make (Resultat) +open Effectful.Make (Or_TypeError) (* TODO: handle more kinds of constant expression *) let convert_enum_expr = @@ -372,21 +372,21 @@ let add_datatype_infos env dts = ListM.fold_leftM add_datatype_info env dts module E = struct type evaluation_scope = string - type 'a m = + type 'a t = | Done of 'a | Error of TypeErrors.t - | ScopeExists of Locations.t * evaluation_scope * (bool -> 'a m) + | ScopeExists of Locations.t * evaluation_scope * (bool -> 'a t) | Value_of_c_variable of - Locations.t * Sym.t * evaluation_scope option * (IT.Surface.t option -> 'a m) + Locations.t * Sym.t * evaluation_scope option * (IT.Surface.t option -> 'a t) | Deref of Locations.t * IT.Surface.t * evaluation_scope option - * (IT.Surface.t option -> 'a m) + * (IT.Surface.t option -> 'a t) let return x = Done x - let rec bind (m : 'a m) (f : 'a -> 'b m) : 'b m = + let rec bind (m : 'a t) (f : 'a -> 'b t) : 'b t = match m with | Done x -> f x | Error err -> Error err @@ -406,7 +406,7 @@ module E = struct Value_of_c_variable (loc, sym, scope, fun o_v_it -> Done o_v_it) - let liftResultat = function Result.Ok a -> Done a | Result.Error e -> Error e + let liftResult = function Result.Ok a -> Done a | Result.Error e -> Error e end let start_evaluation_scope = "start" @@ -843,7 +843,7 @@ module EffectfulTranslation = struct return (IT (Cast (SBT.proj bt, expr), bt, loc)) | CNExpr_call (fsym, exprs) -> let@ args = ListM.mapM self exprs in - let@ b = liftResultat (Builtins.apply_builtin_funs fsym args loc) in + let@ b = liftResult (Builtins.apply_builtin_funs fsym args loc) in (match b with | Some t -> return t | None -> @@ -1015,7 +1015,7 @@ module EffectfulTranslation = struct | Some v -> return v) | CNExpr_value_of_c_atom (sym, C_kind_enum) -> assert (not (Sym.Set.mem sym locally_bound)); - liftResultat (do_decode_enum env loc sym) + liftResult (do_decode_enum env loc sym) in trans None @@ -1183,8 +1183,8 @@ module ET = EffectfulTranslation module Pure = struct let handle what = function - | E.Done x -> Resultat.return x - | E.Error e -> Resultat.fail e + | E.Done x -> Or_TypeError.return x + | E.Error e -> Or_TypeError.fail e | E.Value_of_c_variable (loc, _, _, _) -> let msg = !^what ^^^ !^"are not allowed to refer to (the state of) C variables." in fail { loc; msg = Generic msg } @@ -1318,14 +1318,14 @@ module LocalState = struct List.fold_left (fun st (p, v) -> add_pointee_value p v st) st pvs - let handle { state; old_states } : 'a E.m -> 'a Resultat.m = + let handle { state; old_states } : 'a E.t -> 'a Or_TypeError.t = let state_for_scope = function | None -> state | Some s -> StringMap.find s old_states in let rec aux = function - | E.Done x -> Resultat.return x - | E.Error e -> Resultat.fail e + | E.Done x -> Or_TypeError.return x + | E.Error e -> Or_TypeError.fail e | E.Value_of_c_variable (loc, sym, scope, k) -> let variable_state = (state_for_scope scope).c_variable_state in let o_v = @@ -1536,7 +1536,7 @@ module UsingLoads = struct fail { loc; msg } - let handle allocations old_states : Cnprog.t E.m -> Cnprog.t Resultat.m = + let handle allocations old_states : Cnprog.t E.t -> Cnprog.t Or_TypeError.t = let rec aux = function | E.Done x -> return x | E.Error e -> fail e diff --git a/backend/cn/lib/coreTypeChecks.ml b/backend/cn/lib/coreTypeChecks.ml index 2b613c86f..5e8666e09 100644 --- a/backend/cn/lib/coreTypeChecks.ml +++ b/backend/cn/lib/coreTypeChecks.ml @@ -1,6 +1,6 @@ (* comparisons between CN base types and Core base types *) -open Effectful.Make (Resultat) +open Effectful.Make (Or_TypeError) module BT = BaseTypes open Cerb_frontend.Core diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 894a1e214..87b622f6f 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -29,9 +29,9 @@ let get_loc_ = CF.Annot.get_loc_ open CF.Core open Pp -open Effectful.Make (Resultat) +open Effectful.Make (Or_TypeError) -let fail = Resultat.fail +let fail = Or_TypeError.fail let do_ail_desugar_op desugar_state f = match f desugar_state with @@ -646,7 +646,7 @@ let rec n_expr ((env, old_states), desugaring_things) (global_types, visible_objects_env) e - : unit Mucore.expr Resultat.m + : unit Mucore.expr Or_TypeError.t = let markers_env, cn_desugaring_state = desugaring_things in let (Expr (annots, pe)) = e in diff --git a/backend/cn/lib/core_to_mucore.mli b/backend/cn/lib/core_to_mucore.mli index 87a154a61..606e4d0db 100644 --- a/backend/cn/lib/core_to_mucore.mli +++ b/backend/cn/lib/core_to_mucore.mli @@ -5,7 +5,7 @@ val normalise_file : inherit_loc:bool -> Cerb_frontend.Cabs_to_ail_effect.fin_markers_env * 'a Cerb_frontend.AilSyntax.sigma -> ('b, unit) Cerb_frontend.Milicore.mi_file -> - unit Mucore.file Resultat.m + unit Mucore.file Or_TypeError.t val arguments_of_at : ('a -> 'b) -> 'a ArgumentTypes.t -> 'b Mucore.arguments diff --git a/backend/cn/lib/effectful.ml b/backend/cn/lib/effectful.ml index 36b76db48..bc2233220 100644 --- a/backend/cn/lib/effectful.ml +++ b/backend/cn/lib/effectful.ml @@ -1,9 +1,9 @@ module type S = sig - type 'a m + type 'a t - val return : 'a -> 'a m + val return : 'a -> 'a t - val bind : 'a m -> ('a -> 'b m) -> 'b m + val bind : 'a t -> ('a -> 'b t) -> 'b t end module Make (T : S) = struct @@ -12,9 +12,7 @@ module Make (T : S) = struct let ( let@ ) = T.bind module ListM = struct - open List - - let rec mapM (f : 'a -> 'b m) (l : 'a list) : 'b list m = + let rec mapM (f : 'a -> 'b t) (l : 'a list) : 'b list t = match l with | [] -> return [] | x :: xs -> @@ -23,7 +21,7 @@ module Make (T : S) = struct return (y :: ys) - let mapfstM (f : 'a -> 'c m) (l : ('a * 'b) list) : ('c * 'b) list m = + let mapfstM (f : 'a -> 'c t) (l : ('a * 'b) list) : ('c * 'b) list t = mapM (fun (a, b) -> let@ c = f a in @@ -31,7 +29,7 @@ module Make (T : S) = struct l - let mapsndM (f : 'b -> 'c m) (l : ('a * 'b) list) : ('a * 'c) list m = + let mapsndM (f : 'b -> 'c t) (l : ('a * 'b) list) : ('a * 'c) list t = mapM (fun (a, b) -> let@ c = f b in @@ -39,7 +37,7 @@ module Make (T : S) = struct l - let mapiM (f : int -> 'a -> 'b m) (l : 'a list) : 'b list m = + let mapiM (f : int -> 'a -> 'b t) (l : 'a list) : 'b list t = let rec aux i l = match l with | [] -> return [] @@ -51,26 +49,26 @@ module Make (T : S) = struct aux 0 l - let map2M (f : 'a -> 'b -> 'c m) (l1 : 'a list) (l2 : 'b list) : 'c list m = + let map2M (f : 'a -> 'b -> 'c t) (l1 : 'a list) (l2 : 'b list) : 'c list t = let l12 = List.combine l1 l2 in mapM (Tools.uncurry f) l12 - let iteriM (f : int -> 'a -> unit m) (l : 'a list) : unit m = + let iteriM (f : int -> 'a -> unit t) (l : 'a list) : unit t = let@ _ = mapiM f l in return () - let iterM (f : 'a -> unit m) (l : 'a list) : unit m = iteriM (fun _ -> f) l + let iterM (f : 'a -> unit t) (l : 'a list) : unit t = iteriM (fun _ -> f) l let concat_mapM f l = let@ xs = mapM f l in - return (concat xs) + return (List.concat xs) let filter_mapM f l = let@ xs = mapM f l in - return (filter_map (fun x -> x) xs) + return (List.filter_map (fun x -> x) xs) let filterM f xs = @@ -84,8 +82,8 @@ module Make (T : S) = struct return (List.map snd (List.filter fst ys)) - let fold_leftM (f : 'a -> 'b -> 'c m) (a : 'a) (bs : 'b list) = - Stdlib.List.fold_left + let fold_leftM (f : 'a -> 'b -> 'c t) (a : 'a) (bs : 'b list) = + List.fold_left (fun aM b -> let@ a = aM in f a b) @@ -93,9 +91,8 @@ module Make (T : S) = struct bs - (* maybe from Exception.lem *) - let fold_rightM (f : 'b -> 'a -> 'c m) (bs : 'b list) (a : 'a) = - Stdlib.List.fold_right + let fold_rightM (f : 'b -> 'a -> 'c t) (bs : 'b list) (a : 'a) = + List.fold_right (fun b aM -> let@ a = aM in f b a) @@ -104,7 +101,7 @@ module Make (T : S) = struct end module PmapM = struct - let foldM (f : 'k -> 'x -> 'y -> 'y m) (map : ('k, 'x) Pmap.map) (init : 'y) : 'y m = + let foldM (f : 'k -> 'x -> 'y -> 'y t) (map : ('k, 'x) Pmap.map) (init : 'y) : 'y t = Pmap.fold (fun k v aM -> let@ a = aM in @@ -113,8 +110,8 @@ module Make (T : S) = struct (return init) - let foldiM (f : int -> 'k -> 'x -> 'y -> 'y m) (map : ('k, 'x) Pmap.map) (init : 'y) - : 'y m + let foldiM (f : int -> 'k -> 'x -> 'y -> 'y t) (map : ('k, 'x) Pmap.map) (init : 'y) + : 'y t = ListM.fold_leftM (fun y (i, (k, x)) -> f i k x y) @@ -131,8 +128,8 @@ module Make (T : S) = struct (return ()) - let mapM (f : 'k -> 'v -> 'w m) (m : ('k, 'v) Pmap.map) (cmp : 'k -> 'k -> int) - : ('k, 'w) Pmap.map m + let mapM (f : 'k -> 'v -> 'w t) (m : ('k, 'v) Pmap.map) (cmp : 'k -> 'k -> int) + : ('k, 'w) Pmap.map t = foldM (fun k v m -> diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index 272c6701c..69234c122 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -37,28 +37,29 @@ module PrevDefs = struct let init_t = { present = StringListMap.empty; defs = IntMap.empty; dt_params = []; failures = [] } +end +module PrevDefsMonad = struct + type 'a t = PrevDefs.t -> ('a * PrevDefs.t) Or_TypeError.t - type 'a m = t -> ('a * t, TypeErrors.t) Result.t - - let return (x : 'a) : 'a m = fun st -> Result.Ok (x, st) + let return (x : 'a) : 'a t = fun st -> Result.Ok (x, st) - let bind (x : 'a m) (f : 'a -> 'b m) : 'b m = + let bind (x : 'a t) (f : 'a -> 'b t) : 'b t = fun st -> match x st with Result.Error e -> Result.Error e | Result.Ok (xv, st) -> f xv st - let get : t m = fun st -> Result.Ok (st, st) + let get : PrevDefs.t t = fun st -> Result.Ok (st, st) - let set (st : t) : unit m = fun _ -> Result.Ok ((), st) + let set (st : PrevDefs.t) : unit t = fun _ -> Result.Ok ((), st) - let upd (f : t -> t) : unit m = bind get (fun st -> set (f st)) + let upd (f : PrevDefs.t -> PrevDefs.t) : unit t = bind get (fun st -> set (f st)) - let get_section section (st : t) = + let get_section section (st : PrevDefs.t) = match IntMap.find_opt section st.defs with None -> [] | Some docs -> docs - let add_to_section section doc (st : t) = + let add_to_section section doc (st : PrevDefs.t) = let current = get_section section st in let defs = IntMap.add section (doc :: current) st.defs in { st with defs } @@ -87,9 +88,10 @@ module PrevDefs = struct return ()) end -module PrevMonad = Effectful.Make (PrevDefs) +open Effectful.Make (PrevDefsMonad) + +open PrevDefsMonad open PrevDefs -open PrevMonad let with_reset_dt_params f = let@ st = get in diff --git a/backend/cn/lib/resultat.ml b/backend/cn/lib/or_TypeError.ml similarity index 93% rename from backend/cn/lib/resultat.ml rename to backend/cn/lib/or_TypeError.ml index 096da12aa..cc3f03bde 100644 --- a/backend/cn/lib/resultat.ml +++ b/backend/cn/lib/or_TypeError.ml @@ -2,8 +2,6 @@ type 'a t = ('a, TypeErrors.t) Result.t -type 'a m = 'a t - let return (a : 'a) : 'a t = Ok a let fail (e : 'e) : 'a t = Error e diff --git a/backend/cn/lib/parse.ml b/backend/cn/lib/parse.ml index 9ec1dfa10..b6c5be29b 100644 --- a/backend/cn/lib/parse.ml +++ b/backend/cn/lib/parse.ml @@ -1,7 +1,7 @@ open Cerb_frontend.Annot -open Resultat +open Or_TypeError -open Effectful.Make (Resultat) +open Effectful.Make (Or_TypeError) open TypeErrors open Pp diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index b61011e04..bf1f01786 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -56,7 +56,7 @@ let get () : s t = fun s -> Ok (s, s) (* due to solver interaction, this has to be used carefully *) let set (s' : s) : unit t = fun _s -> Ok ((), s') -let run (c : Context.t) (m : 'a t) : 'a Resultat.t = +let run (c : Context.t) (m : 'a t) : 'a Or_TypeError.t = match m (empty_s c) with Ok (a, _) -> Ok a | Error e -> Error e @@ -68,7 +68,7 @@ let run_from_pause (f : 'a -> 'b t) (pause : 'a pause) = match pause with Ok (a, s) -> Result.map fst @@ f a s | Error e -> Error e -let pause_to_result (pause : 'a pause) : 'a Resultat.t = Result.map fst pause +let pause_to_result (pause : 'a pause) : 'a Or_TypeError.t = Result.map fst pause let pure (m : 'a t) : 'a t = fun s -> @@ -78,7 +78,7 @@ let pure (m : 'a t) : 'a t = outcome -let sandbox (m : 'a t) : 'a Resultat.t t = +let sandbox (m : 'a t) : 'a Or_TypeError.t t = fun s -> let n = Solver.num_scopes (Option.get s.solver) in Solver.push (Option.get s.solver); @@ -97,14 +97,14 @@ let sandbox (m : 'a t) : 'a Resultat.t t = Ok (outcome, s) -let embed_resultat (m : 'a Resultat.t) : 'a m = +let lift (m : 'a Or_TypeError.t) : 'a m = fun s -> match m with Ok r -> Ok (r, s) | Error e -> Error e (* end basic functions *) module Eff = Effectful.Make (struct - type 'a m = 'a t + type nonrec 'a t = 'a t let bind = bind diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 409aea56c..8d7d646c0 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -26,7 +26,7 @@ val run_from_pause : ('a -> 'b m) -> 'a pause -> ('b, TypeErrors.t) Result.t val pause_to_result : 'a pause -> ('a, TypeErrors.t) Result.t -val sandbox : 'a t -> 'a Resultat.t t +val sandbox : 'a t -> 'a Or_TypeError.t t val get_typing_context : unit -> Context.t m @@ -148,7 +148,7 @@ val test_value_eqs IndexTerms.t list -> unit m -val embed_resultat : 'a Resultat.t -> 'a m +val lift : 'a Or_TypeError.t -> 'a m val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit m diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 8570ca452..31312c47f 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -1379,9 +1379,10 @@ module BaseTyping = struct type label_context = (AT.lt * Where.label * Locations.t) Sym.Map.t let check_against_core_bt loc msg2 cbt bt = - Typing.embed_resultat + Typing.lift (CoreTypeChecks.check_against_core_bt - (fun msg -> Resultat.fail { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) + (fun msg -> + Or_TypeError.fail { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) cbt bt) From 2ac0695fe0bfd1be337ccfccb5afdc9ed973bdf1 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Fri, 27 Dec 2024 02:31:48 +0000 Subject: [PATCH 129/148] CN: Separate well-typed and consistency checks WellTyped/well-formedness checks were intertwined with the typing monad because they also performed consistency checks. This made running just the well-formedness checks slower, and did not allow users to opt-out of running the consistency check. This commit adds variants `consistent` functions, which are variants on the `welltyped` functions. The latter add variables to scope and check basetypes; the former add variables to scope, constraints and resources. It also tidies up the wellTyped.ml module to clarify and restrict which of the typing monad functions it was using. This will be the first step of many to factor out the logging and the error reporting for different phases. This commit also required an update to the `pure` function in the typing monad, so that it can work without a solver (functionality with a solver initialised should be unaffected). Slightly awkwardly, the reshuffle also required gathering and delaying adding the range constraints for global variables, since adding constraints and resources both require the solver to be initialised. This can and should be tidied up, which will come in subsequent commits, but for now this should pass all tests. --- backend/cn/bin/main.ml | 4 +- backend/cn/lib/check.ml | 197 +++++----- backend/cn/lib/resourceInference.ml | 4 +- backend/cn/lib/typing.ml | 4 +- backend/cn/lib/typing.mli | 2 - backend/cn/lib/wellTyped.ml | 546 ++++++++++++++++++-------- tests/cn/implies3.error.c.verify | 2 +- tests/cn/inconsistent.error.c.verify | 2 +- tests/cn/inconsistent2.error.c.verify | 3 + 9 files changed, 501 insertions(+), 263 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index a80720458..0ffdb0d56 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -322,9 +322,9 @@ let verify ~magic_comment_char_dollar (* Callbacks *) ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) ~f:(fun ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused -> - let check (functions, lemmas) = + let check (functions, global_var_constraints, lemmas) = let open Typing in - let@ errors = Check.time_check_c_functions functions in + let@ errors = Check.time_check_c_functions (global_var_constraints, functions) in if not quiet then List.iter (fun (fn, err) -> diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index e1a561f63..6ad4c8778 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -130,7 +130,7 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : (fun ity iv -> let@ () = WellTyped.WCT.is_ct loc (Integer ity) in let bt = Memory.bt_of_sct (Integer ity) in - let@ () = WellTyped.ensure_base_type loc ~expect bt in + let@ () = ensure_base_type loc ~expect bt in return (int_lit_ (Memory.int_of_ival iv) bt loc)) (fun _ft _fv -> unsupported loc !^"floats") (fun ct ptrval -> @@ -144,7 +144,7 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : return (make_array_ ~index_bt ~item_bt values loc)) (fun tag mvals -> let@ () = WellTyped.WCT.is_ct loc (Struct tag) in - let@ () = WellTyped.ensure_base_type loc ~expect (Struct tag) in + let@ () = ensure_base_type loc ~expect (Struct tag) in let mvals = List.map (fun (id, ct, mv) -> (id, Sctypes.of_ctype_unsafe loc ct, mv)) mvals in @@ -232,18 +232,18 @@ let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = let@ () = ensure_base_type loc ~expect (Mu.bt_of_object_value ov) in check_object_value loc ov | Vctype ct -> - let@ () = WellTyped.ensure_base_type loc ~expect CType in + let@ () = ensure_base_type loc ~expect CType in let ct = Sctypes.of_ctype_unsafe loc ct in let@ () = WellTyped.WCT.is_ct loc ct in return (IT.const_ctype_ ct loc) | Vunit -> - let@ () = WellTyped.ensure_base_type loc ~expect Unit in + let@ () = ensure_base_type loc ~expect Unit in return (IT.unit_ loc) | Vtrue -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in return (IT.bool_ true loc) | Vfalse -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in return (IT.bool_ false loc) | Vfunction_addr sym -> let@ () = ensure_base_type loc ~expect (Loc ()) in @@ -252,7 +252,7 @@ let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = return (IT.sym_ (sym, BT.(Loc ()), loc)) | Vlist (_item_cbt, vals) -> let item_bt = Mu.bt_of_value (List.hd vals) in - let@ () = WellTyped.ensure_base_type loc ~expect (List item_bt) in + let@ () = ensure_base_type loc ~expect (List item_bt) in let@ () = ListM.iterM (fun i -> ensure_base_type loc ~expect:item_bt (Mu.bt_of_value i)) vals in @@ -511,10 +511,10 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ binding = get_a sym in (match binding with | BaseType bt -> - let@ () = WellTyped.ensure_base_type loc ~expect bt in + let@ () = ensure_base_type loc ~expect bt in k (sym_ (sym, bt, loc)) | Value lvt -> - let@ () = WellTyped.ensure_base_type loc ~expect (IT.get_bt lvt) in + let@ () = ensure_base_type loc ~expect (IT.get_bt lvt) in k lvt) | PEval v -> let@ () = ensure_base_type loc ~expect (Mu.bt_of_value v) in @@ -582,7 +582,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | Cfvfromint _ -> unsupported loc !^"floats" | Civfromfloat _ -> unsupported loc !^"floats" | PEarray_shift (pe1, ct, pe2) -> - let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in + let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = WellTyped.WCT.is_ct loc ct in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in @@ -608,7 +608,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in k result)) | PEmember_shift (pe, tag, member) -> - let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in + let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun vt -> let@ ct = get_struct_member_type loc tag member in @@ -627,7 +627,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in k result) | PEnot pe -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in check_pexpr pe (fun vt -> k (not_ vt loc)) | PEop (op, pe1, pe2) -> @@ -643,7 +643,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in (match op with | OpDiv -> - let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc expect in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> @@ -658,7 +658,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let ub = CF.Undefined.UB045a_division_by_zero in fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } }))) | OpRem_t -> - let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc expect in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> @@ -673,63 +673,48 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let ub = CF.Undefined.UB045b_modulo_by_zero in fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } }))) | OpEq -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in let@ () = - WellTyped.ensure_base_type - loc - ~expect:(Mu.bt_of_pexpr pe1) - (Mu.bt_of_pexpr pe2) + ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (eq_ (v1, v2) loc))) | OpGt -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in let@ () = check_cmp_ty (Mu.bt_of_pexpr pe1) in let@ () = - WellTyped.ensure_base_type - loc - ~expect:(Mu.bt_of_pexpr pe1) - (Mu.bt_of_pexpr pe2) + ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (gt_ (v1, v2) loc))) | OpLt -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in let@ () = check_cmp_ty (Mu.bt_of_pexpr pe1) in let@ () = - WellTyped.ensure_base_type - loc - ~expect:(Mu.bt_of_pexpr pe1) - (Mu.bt_of_pexpr pe2) + ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (lt_ (v1, v2) loc))) | OpGe -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in let@ () = check_cmp_ty (Mu.bt_of_pexpr pe1) in let@ () = - WellTyped.ensure_base_type - loc - ~expect:(Mu.bt_of_pexpr pe1) - (Mu.bt_of_pexpr pe2) + ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (ge_ (v1, v2) loc))) | OpLe -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in let@ () = check_cmp_ty (Mu.bt_of_pexpr pe1) in let@ () = - WellTyped.ensure_base_type - loc - ~expect:(Mu.bt_of_pexpr pe1) - (Mu.bt_of_pexpr pe2) + ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (le_ (v1, v2) loc))) | OpAnd -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in - let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe2) in + let@ () = ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe1) in + let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (and_ [ v1; v2 ] loc))) | OpOr -> - let@ () = WellTyped.ensure_base_type loc ~expect Bool in - let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe2) in + let@ () = ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe1) in + let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (or_ [ v1; v2 ] loc))) | OpAdd -> not_yet "OpAdd" | OpSub -> @@ -936,7 +921,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } })) | PEis_representable_integer (pe, act) -> let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in let ity = Option.get (Sctypes.is_integer_type act.ct) in check_pexpr pe (fun arg -> k (is_representable_integer arg ity)) @@ -1338,7 +1323,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Ememop memop -> let here = Locations.other __LOC__ in let pointer_eq ?(negate = false) pe1 pe2 = - let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect Bool in let k, case, res = if negate then ((fun x -> k (not_ x loc)), "in", "ptrNeq") else (k, "", "ptrEq") in @@ -1484,9 +1469,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrFromInt (act_from, act_to, pe) -> let@ () = WellTyped.WCT.is_ct act_from.loc act_from.ct in let@ () = WellTyped.WCT.is_ct act_to.loc act_to.ct in - let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in + let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = - WellTyped.ensure_base_type + ensure_base_type loc ~expect:(Memory.bt_of_sct act_from.ct) (Mu.bt_of_pexpr pe) @@ -1511,8 +1496,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrValidForDeref (act, pe) -> (* TODO (DCM, VIP) *) let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = WellTyped.ensure_base_type loc ~expect Bool in - let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in (* TODO (DCM, VIP): error if called on Void or Function Ctype. return false if resource missing *) check_pexpr pe (fun arg -> @@ -1526,8 +1511,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k result) | PtrWellAligned (act, pe) -> let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = WellTyped.ensure_base_type loc ~expect Bool in - let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = ensure_base_type loc ~expect Bool in + let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in (* TODO (DCM, VIP): error if called on Void or Function Ctype *) check_pexpr pe (fun arg -> (* let unspec = CF.Undefined.UB_unspec_pointer_add in *) @@ -1560,12 +1545,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (Loc.other __LOC__) !^"PtrMemberShift should be a CHERI only construct" | CopyAllocId (pe1, pe2) -> - let@ () = - WellTyped.ensure_base_type loc ~expect:Memory.uintptr_bt (Mu.bt_of_pexpr pe1) - in - let@ () = - WellTyped.ensure_base_type loc ~expect:BT.(Loc ()) (Mu.bt_of_pexpr pe2) - in + let@ () = ensure_base_type loc ~expect:Memory.uintptr_bt (Mu.bt_of_pexpr pe1) in + let@ () = ensure_base_type loc ~expect:BT.(Loc ()) (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> let unspec = CF.Undefined.UB_unspec_copy_alloc_id in @@ -1590,7 +1571,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (match action_ with | Create (pe, act, prefix) -> let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in + let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let ret_s, ret = @@ -1641,7 +1622,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = Cerb_debug.error "todo: Free" | Kill (Static ct, pe) -> let@ () = WellTyped.WCT.is_ct loc ct in - let@ () = WellTyped.ensure_base_type loc ~expect Unit in + let@ () = ensure_base_type loc ~expect Unit in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let@ _ = @@ -1657,15 +1638,10 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k (unit_ loc)) | Store (_is_locking, act, p_pe, v_pe, _mo) -> let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = WellTyped.ensure_base_type loc ~expect Unit in + let@ () = ensure_base_type loc ~expect Unit in + let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) in let@ () = - WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) - in - let@ () = - WellTyped.ensure_base_type - loc - ~expect:(Memory.bt_of_sct act.ct) - (Mu.bt_of_pexpr v_pe) + ensure_base_type loc ~expect:(Memory.bt_of_sct act.ct) (Mu.bt_of_pexpr v_pe) in check_pexpr p_pe (fun parg -> check_pexpr v_pe (fun varg -> @@ -1704,10 +1680,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k (unit_ loc))) | Load (act, p_pe, _mo) -> let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in - let@ () = - WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) - in + let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in + let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) in check_pexpr p_pe (fun pointer -> let@ value = load loc pointer act.ct in k value) @@ -1722,7 +1696,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | LinuxStore (_ct, _sym1, _sym2, _mo) -> Cerb_debug.error "todo: LinuxStore" | LinuxRMW (_ct, _sym1, _sym2, _mo) -> Cerb_debug.error "todo: LinuxRMW") | Eskip -> - let@ () = WellTyped.ensure_base_type loc ~expect Unit in + let@ () = ensure_base_type loc ~expect Unit in k (unit_ loc) | Eccall (act, f_pe, pes) -> let@ () = WellTyped.WCT.is_ct act.loc act.ct in @@ -1748,7 +1722,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in (* checks pes against their annotations, and that they match ft's argument types *) Spine.calltype_ft loc ~fsym pes ft (fun (Computational ((_, bt), _, _) as rt) -> - let@ () = WellTyped.ensure_base_type loc ~expect bt in + let@ () = ensure_base_type loc ~expect bt in let@ _, members = make_return_record loc @@ -1846,7 +1820,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in eq_ (lhs, rhs) here in - let@ () = WellTyped.ensure_base_type loc ~expect Unit in + let@ () = ensure_base_type loc ~expect Unit in let aux loc stmt = (* copying bits of code from elsewhere in check.ml *) match stmt with @@ -2077,7 +2051,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let check_expr_top loc labels rt e = - let@ () = WellTyped.ensure_base_type loc ~expect:Unit (Mu.bt_of_expr e) in + let@ () = ensure_base_type loc ~expect:Unit (Mu.bt_of_expr e) in check_expr labels e (fun lvt -> let (RT.Computational ((return_s, return_bt), _info, lrt)) = rt in match return_bt with @@ -2280,11 +2254,10 @@ let record_and_check_resource_predicates preds = preds -let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> unit m = +let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> LC.t list m = fun globs -> - (* TODO: check the expressions *) - ListM.iterM - (fun (sym, def) -> + ListM.fold_leftM + (fun acc (sym, def) -> match def with | Mu.GlobalDef (ct, _) | GlobalDecl ct -> let@ () = WellTyped.WCT.is_ct (Loc.other __LOC__) ct in @@ -2292,12 +2265,10 @@ let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> unit m = let info = (Loc.other __LOC__, lazy (Pp.item "global" (Sym.pp sym))) in let@ () = add_a sym bt info in let here = Locations.other __LOC__ in - let@ () = - add_c here (LC.T (IT.good_pointer ~pointee_ct:ct (sym_ (sym, bt, here)) here)) - in + let good = LC.T (IT.good_pointer ~pointee_ct:ct (sym_ (sym, bt, here)) here) in let ptr = sym_ (sym, bt, here) in - let@ () = add_c here (LC.T (IT.hasAllocId_ ptr here)) in - let@ () = + let hasAllocId = LC.T (IT.hasAllocId_ ptr here) in + let range = if !IT.use_vip then let module H = Alloc.History in let H.{ base; size } = H.(split (lookup_ptr ptr here) here) in @@ -2311,11 +2282,13 @@ let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> unit m = ] here in - add_c here (LC.T bounds) + [ LC.T bounds ] else - return () + [] in - return ()) + (* TODO: check the expressions *) + return (good :: hasAllocId :: (range @ acc))) + [] globs @@ -2645,8 +2618,7 @@ let check_decls_lemmata_fun_specs (file : unit Mu.file) = let@ () = record_tagdefs file.tagDefs in let@ () = check_tagdefs file.tagDefs in let@ () = record_and_check_datatypes file.datatypes in - let@ () = init_solver () in - let@ () = record_globals file.globs in + let@ global_var_constraints = record_globals file.globs in let@ () = register_fun_syms file in let@ () = ListM.iterM (add_stdlib_spec file.call_funinfo) (Sym.Set.elements file.stdlib_syms) @@ -2662,14 +2634,41 @@ let check_decls_lemmata_fun_specs (file : unit Mu.file) = let@ _trusted, checked = wf_check_and_record_functions file.funs file.call_funinfo in Pp.debug 3 (lazy (Pp.headline "type-checked C functions and specifications.")); Cerb_debug.end_csv_timing "decl, lemmata, function specification checking"; - return (List.rev checked, lemmata) + return (List.rev checked, global_var_constraints, lemmata) (** With CSV timing enabled, check the provided functions with [check_c_functions]. See that function for more information on the semantics of checking. *) -let time_check_c_functions (checked : c_function list) : (string * TypeErrors.t) list m = +let time_check_c_functions (global_var_constraints, (checked : c_function list)) + : (string * TypeErrors.t) list m + = Cerb_debug.begin_csv_timing () (*type checking functions*); + let@ () = init_solver () in + let here = Locations.other __LOC__ in + let@ () = add_cs here global_var_constraints in + let@ global = get_global () in + let@ () = + Sym.Map.fold + (fun _ def acc -> + (* I think this avoids a left-recursion in the monad bind *) + let@ () = WellTyped.WRPD.consistent def in + acc) + global.resource_predicates + (return ()) + in + let@ () = + Sym.Map.fold + (fun _ (loc, def, _) acc -> + match def with + | None -> acc + | Some def -> + (* I think this avoids a left-recursion in the monad bind *) + let@ () = WellTyped.WFT.consistent "proc/fun" loc def in + acc) + global.fun_decls + (return ()) + in let@ errors = check_c_functions checked in Cerb_debug.end_csv_timing "type checking functions"; return errors @@ -2678,7 +2677,17 @@ let time_check_c_functions (checked : c_function list) : (string * TypeErrors.t) let generate_lemmas lemmata o_lemma_mode = let@ global = get_global () in match o_lemma_mode with - | Some mode -> lift (Lemmata.generate global mode lemmata) + | Some mode -> + let@ () = + Sym.Map.fold + (fun sym (loc, lemma_typ) acc -> + (* I think this avoids a left-recursion in the monad bind *) + let@ () = WellTyped.WLemma.consistent loc sym lemma_typ in + acc) + global.lemmata + (return ()) + in + lift (Lemmata.generate global mode lemmata) | None -> return () (* TODO: diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 07e11f63a..285f1dfb6 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -160,7 +160,7 @@ module General = struct = Pp.(debug 7 (lazy (item __LOC__ (Req.pp (P requested))))); let start_timing = Pp.time_log_start __LOC__ "" in - let@ oarg_bt = WellTyped.oarg_bt_of_pred loc requested.name in + let@ oarg_bt = WellTyped.WRS.oarg_bt_of_pred loc requested.name in let@ provable = provable loc in let@ global = get_global () in let@ simp_ctxt = simp_ctxt () in @@ -384,7 +384,7 @@ module General = struct and qpredicate_request loc uiinfo (requested : Req.QPredicate.t) = let@ o_oarg = qpredicate_request_aux loc uiinfo requested in - let@ oarg_item_bt = WellTyped.oarg_bt_of_pred loc requested.name in + let@ oarg_item_bt = WellTyped.WRS.oarg_bt_of_pred loc requested.name in match o_oarg with | None -> return None | Some (oarg, rw_time) -> diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index bf1f01786..72d392b29 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -72,9 +72,9 @@ let pause_to_result (pause : 'a pause) : 'a Or_TypeError.t = Result.map fst paus let pure (m : 'a t) : 'a t = fun s -> - Solver.push (Option.get s.solver); + Option.iter Solver.push s.solver; let outcome = match m s with Ok (a, _) -> Ok (a, s) | Error e -> Error e in - Solver.pop (Option.get s.solver) 1; + Option.iter (fun s -> Solver.pop s 1) s.solver; outcome diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 8d7d646c0..2c0b95fda 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -1,5 +1,3 @@ -type solver - type 'a t type 'a m = 'a t diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 31312c47f..981ade6b8 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -2,29 +2,69 @@ module CF = Cerb_frontend module BT = BaseTypes module IT = IndexTerms module Loc = Locations -module LC = LogicalConstraints -module TE = TypeErrors -module Res = Resource -module Req = Request -module Def = Definition -module LRT = LogicalReturnTypes -module AT = ArgumentTypes -module LAT = LogicalArgumentTypes -module Mu = Mucore module IdSet = Set.Make (Id) -open Context -open Global -open TE -open Pp -open Typing +open Pp.Infix + +let squotes, warn, dot, string, debug, item, colon, comma = + Pp.(squotes, warn, dot, string, debug, item, colon, comma) + + +module type NoSolver = sig + (** TODO make this abstract, and one-way lifting functions? *) + type 'a m = 'a Typing.t + + (* TODO: different error types for type errors, consistency errors, proof errors *) + type failure = Context.t * Explain.log -> TypeErrors.t + + val pure : 'a m -> 'a m + + val fail : failure -> 'a m + + val bound_a : Sym.t -> bool m + + val bound_l : Sym.t -> bool m + + val get_a : Sym.t -> Context.basetype_or_value m + + val get_l : Sym.t -> Context.basetype_or_value m + + val add_a : Sym.t -> BT.t -> Context.l_info -> unit m + + val add_l : Sym.t -> BT.t -> Context.l_info -> unit m + + val get_struct_decl : Loc.t -> Sym.t -> Memory.struct_layout m + + val get_struct_member_type : Loc.t -> Sym.t -> Id.t -> Sctypes.ctype m + + val get_datatype : Loc.t -> Sym.t -> BT.dt_info m + + val get_datatype_constr : Loc.t -> Sym.t -> BT.constr_info m + + val get_resource_predicate_def : Loc.t -> Sym.t -> Definition.Predicate.t m + + val get_logical_function_def : Loc.t -> Sym.t -> Definition.Function.t m + + val get_lemma : Loc.t -> Sym.t -> (Cerb_location.t * ArgumentTypes.lemmat) m + + val get_fun_decl + : Loc.t -> + Sym.t -> + (Loc.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) m + + val ensure_base_type : Loc.t -> expect:BT.t -> BT.t -> unit m + + val lift : 'a Or_TypeError.t -> 'a m +end + +open (Typing : NoSolver) + +let fail typeErr = fail (fun _ -> typeErr) open Effectful.Make (Typing) let use_ity = ref true -let ensure_base_type = Typing.ensure_base_type - -let illtyped_index_term (loc : Locations.t) it has ~expected ~reason (_ctxt, _log) = +let illtyped_index_term (loc : Locations.t) it has ~expected ~reason = let reason = match reason with | Either.Left reason -> @@ -32,16 +72,14 @@ let illtyped_index_term (loc : Locations.t) it has ~expected ~reason (_ctxt, _lo head ^ "\n" ^ pos | Either.Right reason -> reason in - { loc; - msg = TypeErrors.Illtyped_it { it = IT.pp it; has = BT.pp has; expected; reason } - } + TypeErrors. + { loc; msg = Illtyped_it { it = IT.pp it; has = BT.pp has; expected; reason } } let ensure_bits_type (loc : Loc.t) (has : BT.t) = match has with | BT.Bits (_sign, _n) -> return () - | has -> - fail (fun _ -> { loc; msg = Mismatch { has = BT.pp has; expect = !^"bitvector" } }) + | has -> fail { loc; msg = Mismatch { has = BT.pp has; expect = !^"bitvector" } } let ensure_z_fits_bits_type loc (sign, n) v = @@ -49,7 +87,7 @@ let ensure_z_fits_bits_type loc (sign, n) v = return () else ( let err = !^"Value" ^^^ Pp.z v ^^^ !^"does not fit" ^^^ BT.pp (Bits (sign, n)) in - fail (fun _ -> { loc; msg = Generic err })) + fail { loc; msg = Generic err }) let ensure_arith_type ~reason it = @@ -117,9 +155,9 @@ let ensure_same_argument_number loc input_output has ~expect = return () else ( match input_output with - | `General -> fail (fun _ -> { loc; msg = Number_arguments { has; expect } }) - | `Input -> fail (fun _ -> { loc; msg = Number_input_arguments { has; expect } }) - | `Output -> fail (fun _ -> { loc; msg = Number_output_arguments { has; expect } })) + | `General -> fail { loc; msg = Number_arguments { has; expect } } + | `Input -> fail { loc; msg = Number_input_arguments { has; expect } } + | `Output -> fail { loc; msg = Number_output_arguments { has; expect } }) let compare_by_fst_id (x, _) (y, _) = Id.compare x y @@ -132,13 +170,13 @@ let correct_members loc (spec : (Id.t * 'a) list) (have : (Id.t * 'b) list) = if IdSet.mem id needed then return (IdSet.remove id needed) else - fail (fun _ -> { loc; msg = Unexpected_member (List.map fst spec, id) })) + fail { loc; msg = Unexpected_member (List.map fst spec, id) }) needed have in match IdSet.elements needed with | [] -> return () - | missing :: _ -> fail (fun _ -> { loc; msg = Missing_member missing }) + | missing :: _ -> fail { loc; msg = Missing_member missing } let correct_members_sorted_annotated loc spec have = @@ -206,8 +244,8 @@ module WBT = struct match BT.pick_integer_encoding_type z with | Some bt -> return bt | None -> - fail (fun _ -> - { loc; msg = Generic (Pp.item "no standard encoding type for constant" (Pp.z z)) }) + fail + { loc; msg = Generic (Pp.item "no standard encoding type for constant" (Pp.z z)) } end module WCT = struct @@ -228,6 +266,7 @@ module WCT = struct end module WIT = struct + module LC = LogicalConstraints open BaseTypes open IndexTerms @@ -280,7 +319,7 @@ module WIT = struct | [] -> assert (List.for_all (function [] -> true | _ -> false) cases); (match cases with - | [] -> fail (fun _ -> { loc; msg = Generic !^"Incomplete pattern" }) + | [] -> fail { loc; msg = Generic !^"Incomplete pattern" } | _ -> return ()) (* | [_(\*[]*\)] -> return () *) (* | _::_::_ -> fail (fun _ -> {loc; msg = Generic !^"Duplicate pattern"}) *) @@ -358,7 +397,7 @@ module WIT = struct ^/^ !^prev_pos ^^ !^suggestion in - fail (fun _ -> { loc = pat_loc; msg = Redundant_pattern err })) + fail { loc = pat_loc; msg = Redundant_pattern err }) [] pats in @@ -367,7 +406,7 @@ module WIT = struct let rec get_location_for_type = function | IT (Apply (name, _args), _, loc) -> - let@ def = Typing.get_logical_function_def loc name in + let@ def = get_logical_function_def loc name in return def.loc | IT ((MapSet (t, _, _) | Let (_, t)), _, _) -> get_location_for_type t | IT (Cons (it, _), _, _) | it -> return @@ IT.get_loc it @@ -389,7 +428,7 @@ module WIT = struct match () with | () when is_a -> get_a s | () when is_l -> get_l s - | () -> fail (fun _ -> { loc; msg = TE.Unknown_variable s }) + | () -> fail { loc; msg = TypeErrors.Unknown_variable s } in (match binding with | BaseType bt -> return (IT (Sym s, bt, loc)) @@ -718,10 +757,10 @@ module WIT = struct let@ () = match (IT.get_bt t, cbt) with | Integer, Loc () -> - fail (fun _ -> + fail { loc; msg = Generic !^"cast from integer not allowed in bitvector version" - }) + } | Loc (), Alloc_id -> return () | Integer, Real -> return () | Real, Integer -> return () @@ -741,7 +780,7 @@ module WIT = struct ^^^ BT.pp target ^^ dot in - fail (fun _ -> { loc; msg = Generic msg }) + fail { loc; msg = Generic msg } in return (IT (Cast (cbt, t), cbt, loc)) | MemberShift (t, tag, member) -> @@ -853,14 +892,14 @@ module WIT = struct if BT.equal ix_bt (IT.get_bt i) then return () else - fail (fun _ -> + fail { loc; msg = Generic (Pp.item "array_to_list: index type disagreement" (Pp.list IT.pp_with_typ [ i; arr ])) - }) + } in return (IT (ArrayToList (arr, i, len), BT.List bt, loc)) | MapConst (index_bt, t) -> @@ -886,7 +925,7 @@ module WIT = struct let@ body = infer body in return (IT (MapDef ((s, abt), body), Map (abt, IT.get_bt body), loc))) | Apply (name, args) -> - let@ def = Typing.get_logical_function_def loc name in + let@ def = get_logical_function_def loc name in let has_args, expect_args = (List.length args, List.length def.args) in let@ () = ensure_same_argument_number loc `General has_args ~expect:expect_args in let@ args = @@ -902,7 +941,7 @@ module WIT = struct let@ t1 = infer t1 in pure (let@ () = add_l name (IT.get_bt t1) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c loc (LC.T (IT.def_ name t1 loc)) in + (* let@ () = add_c loc (LC.T (IT.def_ name t1 loc)) in *) let@ t2 = infer t2 in return (IT (Let ((name, t1), t2), IT.get_bt t2, loc))) | Constructor (s, args) -> @@ -937,7 +976,7 @@ module WIT = struct let@ () = cases_necessary (List.map (fun (pat, _) -> pat) cases) in let@ rbt = match rbt with - | None -> fail (fun _ -> { loc; msg = Empty_pattern }) + | None -> fail { loc; msg = Empty_pattern } | Some rbt -> return rbt in return (IT (Match (e, cases), rbt, loc)) @@ -965,7 +1004,7 @@ let warn_when_not_quantifier_bt (ident : string) (loc : Locations.t) (bt : BaseTypes.t) - (sym : document option) + (sym : Pp.document option) : unit = if not (BT.equal bt quantifier_bt) then @@ -981,6 +1020,7 @@ let warn_when_not_quantifier_bt module WReq = struct + module Req = Request open IndexTerms let welltyped loc r = @@ -989,7 +1029,7 @@ module WReq = struct match Req.get_name r with | Owned (_ct, _init) -> return [] | PName name -> - let@ def = Typing.get_resource_predicate_def loc name in + let@ def = get_resource_predicate_def loc name in return def.iargs in match r with @@ -1023,16 +1063,16 @@ module WReq = struct if Z.lt Z.zero z then return step else - fail (fun _ -> + fail { loc; msg = Generic (!^"Iteration step" ^^^ IT.pp p.step ^^^ !^"must be positive") - }) + } | IT (SizeOf _, _, _) -> return step | IT (Cast (_, IT (SizeOf _, _, _)), _, _) -> return step | _ -> let hint = "Only constant iteration steps are allowed." in - fail (fun _ -> { loc; msg = NIA { it = p.step; hint } }) + fail { loc; msg = NIA { it = p.step; hint } } in (*let@ () = match p.name with | (Owned (ct, _init)) -> let sz = Memory.size_of_ctype ct in if IT.equal step (IT.int_lit_ sz (snd p.q)) then return () else fail (fun _ @@ -1085,23 +1125,22 @@ module WReq = struct { name = p.name; pointer; q = p.q; q_loc = p.q_loc; step; permission; iargs }) end -let oarg_bt_of_pred loc = function - | Req.Owned (ct, _init) -> return (Memory.bt_of_sct ct) - | Req.PName pn -> - let@ def = Typing.get_resource_predicate_def loc pn in - return def.oarg_bt +module WRS = struct + let oarg_bt_of_pred loc = function + | Request.Owned (ct, _init) -> return (Memory.bt_of_sct ct) + | Request.PName pn -> + let@ def = get_resource_predicate_def loc pn in + return def.oarg_bt -let oarg_bt loc = function - | Req.P pred -> oarg_bt_of_pred loc pred.name - | Req.Q pred -> - let@ item_bt = oarg_bt_of_pred loc pred.name in - return (BT.make_map_bt (snd pred.q) item_bt) + let oarg_bt loc = function + | Request.P pred -> oarg_bt_of_pred loc pred.name + | Request.Q pred -> + let@ item_bt = oarg_bt_of_pred loc pred.name in + return (BT.make_map_bt (snd pred.q) item_bt) -module WRS = struct let welltyped loc (resource, bt) = - Pp.(debug 6 (lazy !^__LOC__)); let@ resource = WReq.welltyped loc resource in let@ bt = WBT.is_bt loc bt in let@ oarg_bt = oarg_bt loc resource in @@ -1110,7 +1149,7 @@ module WRS = struct end module WLC = struct - type t = LogicalConstraints.t + module LC = LogicalConstraints let welltyped loc lc = match lc with @@ -1127,66 +1166,87 @@ module WLC = struct end module WLRT = struct + module LC = LogicalConstraints module LRT = LogicalReturnTypes - open LRT - type t = LogicalReturnTypes.t - - let welltyped loc lrt = + let consistent loc lrt = + let open Typing in let rec aux = let here = Locations.other __LOC__ in function - | Define ((s, it), ((loc, _) as info), lrt) -> + | LRT.Define ((s, it), ((loc, _) as info), lrt) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ it = WIT.infer it in let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in + aux lrt + | Resource ((s, (re, re_oa_spec)), (loc, _), lrt) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in + let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in + aux lrt + | Constraint (lc, info, lrt) -> + (* TODO abort early if one of the constraints is the literal fase, + so that users are allowed to write such specs *) + let@ () = add_c (fst info) lc in + aux lrt + | I -> + let@ provable = provable loc in + let here = Locations.other __LOC__ in + (match provable (LC.T (IT.bool_ false here)) with + | `True -> + fail (fun ctxt_log -> + { loc; msg = Inconsistent_assumptions ("return type", ctxt_log) }) + | `False -> return ()) + in + pure (aux lrt) + + + let welltyped _loc lrt = + let rec aux = function + | LRT.Define ((s, it), ((loc, _) as info), lrt) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ it = WIT.infer it in + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ lrt = aux lrt in - return (Define ((s, it), info, lrt)) + return (LRT.Define ((s, it), info, lrt)) | Resource ((s, (re, re_oa_spec)), ((loc, _) as info), lrt) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ re, re_oa_spec = WRS.welltyped loc (re, re_oa_spec) in let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in - let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in let@ lrt = aux lrt in - return (Resource ((s, (re, re_oa_spec)), info, lrt)) + return (LRT.Resource ((s, (re, re_oa_spec)), info, lrt)) | Constraint (lc, info, lrt) -> let@ lc = WLC.welltyped (fst info) lc in - let@ () = add_c (fst info) lc in let@ lrt = aux lrt in - return (Constraint (lc, info, lrt)) - | I -> - let@ provable = provable loc in - let here = Locations.other __LOC__ in - let@ () = - match provable (LC.T (IT.bool_ false here)) with - | `True -> - fail (fun ctxt_log -> - { loc; msg = Inconsistent_assumptions ("return type", ctxt_log) }) - | `False -> return () - in - return I + return (LRT.Constraint (lc, info, lrt)) + | I -> return LRT.I in pure (aux lrt) end module WRT = struct - type t = ReturnTypes.t - let subst = ReturnTypes.subst let pp = ReturnTypes.pp + let consistent loc rt = + pure + (match rt with + | ReturnTypes.Computational ((name, bt), info, lrt) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in + WLRT.consistent loc lrt) + + let welltyped loc rt = - Pp.(debug 6 (lazy !^__LOC__)); pure (match rt with - | RT.Computational ((name, bt), info, lrt) -> + | ReturnTypes.Computational ((name, bt), info, lrt) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ bt = WBT.is_bt (fst info) bt in let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in let@ lrt = WLRT.welltyped loc lrt in - return (RT.Computational ((name, bt), info, lrt))) + return (ReturnTypes.Computational ((name, bt), info, lrt))) end (* module WFalse = struct *) @@ -1200,13 +1260,18 @@ end (* end *) let pure_and_no_initial_resources loc m = + let open Typing in pure (let@ (), _ = map_and_fold_resources loc (fun _re () -> (Deleted, ())) () in m) module WLAT = struct - let welltyped i_welltyped i_pp kind loc (at : 'i LAT.t) : 'i LAT.t m = + module LC = LogicalConstraints + module LAT = LogicalArgumentTypes + + let consistent i_welltyped i_pp kind loc (at : 'i LAT.t) : unit m = + let open Typing in debug 12 (lazy @@ -1216,23 +1281,17 @@ module WLAT = struct function | LAT.Define ((s, it), info, at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ it = WIT.infer it in let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in - let@ at = aux at in - return (LAT.Define ((s, it), info, at)) - | LAT.Resource ((s, (re, re_oa_spec)), ((loc, _) as info), at) -> + aux at + | LAT.Resource ((s, (re, re_oa_spec)), (loc, _), at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ re, re_oa_spec = WRS.welltyped (fst info) (re, re_oa_spec) in let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in - let@ at = aux at in - return (LAT.Resource ((s, (re, re_oa_spec)), info, at)) + aux at | LAT.Constraint (lc, info, at) -> - let@ lc = WLC.welltyped (fst info) lc in let@ () = add_c (fst info) lc in - let@ at = aux at in - return (LAT.Constraint (lc, info, at)) + aux at | LAT.I i -> let@ provable = provable loc in let here = Locations.other __LOC__ in @@ -1243,6 +1302,34 @@ module WLAT = struct { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) | `False -> return () in + i_welltyped loc i + in + pure (aux at) + + + let welltyped i_welltyped i_pp kind loc (at : 'i LAT.t) : 'i LAT.t m = + debug + 12 + (lazy + (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (LAT.pp i_pp at))); + let rec aux = function + | LAT.Define ((s, it), info, at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ it = WIT.infer it in + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in + let@ at = aux at in + return (LAT.Define ((s, it), info, at)) + | LAT.Resource ((s, (re, re_oa_spec)), ((loc, _) as info), at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ re, re_oa_spec = WRS.welltyped (fst info) (re, re_oa_spec) in + let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in + let@ at = aux at in + return (LAT.Resource ((s, (re, re_oa_spec)), info, at)) + | LAT.Constraint (lc, info, at) -> + let@ lc = WLC.welltyped (fst info) lc in + let@ at = aux at in + return (LAT.Constraint (lc, info, at)) + | LAT.I i -> let@ i = i_welltyped loc i in return (LAT.I i) in @@ -1250,6 +1337,23 @@ module WLAT = struct end module WAT = struct + module AT = ArgumentTypes + + let consistent i_welltyped i_pp kind loc (at : 'i AT.t) : unit m = + debug + 12 + (lazy + (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (AT.pp i_pp at))); + let rec aux = function + | AT.Computational ((name, bt), info, at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in + aux at + | AT.L at -> WLAT.consistent i_welltyped i_pp kind loc at + in + pure (aux at) + + let welltyped i_welltyped i_pp kind loc (at : 'i AT.t) : 'i AT.t m = debug 12 @@ -1270,6 +1374,12 @@ module WAT = struct end module WFT = struct + let consistent = + WAT.consistent + (fun loc rt -> pure_and_no_initial_resources loc (WRT.consistent loc rt)) + WRT.pp + + let welltyped = WAT.welltyped (fun loc rt -> pure_and_no_initial_resources loc (WRT.welltyped loc rt)) @@ -1286,6 +1396,10 @@ end (pd.oargs)) *) module WLArgs = struct + module LC = LogicalConstraints + module LAT = LogicalArgumentTypes + module Mu = Mucore + let rec typ ityp = function | Mu.Define (bound, info, lat) -> LAT.Define (bound, info, typ ityp lat) | Mu.Resource (bound, info, lat) -> LAT.Resource (bound, info, typ ityp lat) @@ -1293,32 +1407,26 @@ module WLArgs = struct | Mu.I i -> LAT.I (ityp i) - let welltyped (i_welltyped : Loc.t -> 'i -> 'j m) kind loc (at : 'i Mu.arguments_l) - : 'j Mu.arguments_l m + let consistent (i_welltyped : Loc.t -> 'i -> 'j m) kind loc (at : 'i Mu.arguments_l) + : unit m = + let open Typing in let rec aux = let here = Locations.other __LOC__ in - Pp.(debug 6 (lazy !^__LOC__)); function | Mu.Define ((s, it), ((loc, _) as info), at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ it = WIT.infer it in let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in - let@ at = aux at in - return (Mu.Define ((s, it), info, at)) - | Mu.Resource ((s, (re, re_oa_spec)), ((loc, _) as info), at) -> + aux at + | Mu.Resource ((s, (re, re_oa_spec)), (loc, _), at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ re, re_oa_spec = WRS.welltyped (fst info) (re, re_oa_spec) in let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in - let@ at = aux at in - return (Mu.Resource ((s, (re, re_oa_spec)), info, at)) + aux at | Mu.Constraint (lc, info, at) -> - let@ lc = WLC.welltyped (fst info) lc in let@ () = add_c (fst info) lc in - let@ at = aux at in - return (Mu.Constraint (lc, info, at)) + aux at | Mu.I i -> let@ provable = provable loc in let here = Locations.other __LOC__ in @@ -1329,6 +1437,32 @@ module WLArgs = struct { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) | `False -> return () in + i_welltyped loc i + in + pure (aux at) + + + let welltyped (i_welltyped : Loc.t -> 'i -> 'j m) _kind loc (at : 'i Mu.arguments_l) + : 'j Mu.arguments_l m + = + let rec aux = function + | Mu.Define ((s, it), ((loc, _) as info), at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ it = WIT.infer it in + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in + let@ at = aux at in + return (Mu.Define ((s, it), info, at)) + | Mu.Resource ((s, (re, re_oa_spec)), ((loc, _) as info), at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ re, re_oa_spec = WRS.welltyped (fst info) (re, re_oa_spec) in + let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in + let@ at = aux at in + return (Mu.Resource ((s, (re, re_oa_spec)), info, at)) + | Mu.Constraint (lc, info, at) -> + let@ lc = WLC.welltyped (fst info) lc in + let@ at = aux at in + return (Mu.Constraint (lc, info, at)) + | Mu.I i -> let@ i = i_welltyped loc i in return (Mu.I i) in @@ -1336,11 +1470,34 @@ module WLArgs = struct end module WArgs = struct + module AT = ArgumentTypes + module Mu = Mucore + let rec typ ityp = function | Mu.Computational (bound, info, at) -> AT.Computational (bound, info, typ ityp at) | Mu.L lat -> AT.L (WLArgs.typ ityp lat) + let consistent : (Loc.t -> 'i -> 'j m) -> string -> Loc.t -> 'i Mu.arguments -> unit m = + fun (i_welltyped : Loc.t -> 'i -> 'j m) kind loc (at : 'i Mu.arguments) -> + debug 6 (lazy !^__LOC__); + debug + 12 + (lazy + (item + ("checking consistency of " ^ kind ^ " at " ^ Loc.to_string loc) + (CF.Pp_ast.pp_doc_tree + (Mucore.dtree_of_arguments (fun _i -> Dleaf !^"...") at)))); + let rec aux = function + | Mu.Computational ((name, bt), info, at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in + aux at + | Mu.L at -> WLArgs.consistent i_welltyped kind loc at + in + pure (aux at) + + let welltyped : 'i 'j. (Loc.t -> 'i -> 'j m) -> string -> Loc.t -> 'i Mu.arguments -> 'j Mu.arguments m @@ -1369,7 +1526,6 @@ module WArgs = struct end module BaseTyping = struct - open Typing open TypeErrors module BT = BaseTypes module RT = ReturnTypes @@ -1379,7 +1535,7 @@ module BaseTyping = struct type label_context = (AT.lt * Where.label * Locations.t) Sym.Map.t let check_against_core_bt loc msg2 cbt bt = - Typing.lift + lift (CoreTypeChecks.check_against_core_bt (fun msg -> Or_TypeError.fail { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) @@ -1387,6 +1543,8 @@ module BaseTyping = struct bt) + module Mu = Mucore + let rec check_and_bind_pattern bt = function | Mu.Pattern (loc, anns, _, p_) -> let@ p_ = check_and_bind_pattern_ bt loc p_ in @@ -1412,8 +1570,7 @@ module BaseTyping = struct match BT.is_list_bt bt with | Some bt -> return bt | None -> - fail (fun _ -> - { loc; msg = Generic (Pp.item "list pattern match against" (BT.pp bt)) }) + fail { loc; msg = Generic (Pp.item "list pattern match against" (BT.pp bt)) } in let@ ctor, pats = match (ctor, pats) with @@ -1421,22 +1578,20 @@ module BaseTyping = struct let@ _item_bt = get_item_bt bt in return (Mu.Cnil cbt, []) | Cnil _, _ -> - fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pats; expect = 0 } }) + fail { loc; msg = Number_arguments { has = List.length pats; expect = 0 } } | Ccons, [ p1; p2 ] -> let@ item_bt = get_item_bt bt in let@ p1 = check_and_bind_pattern item_bt p1 in let@ p2 = check_and_bind_pattern bt p2 in return (Mu.Ccons, [ p1; p2 ]) | Ccons, _ -> - fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pats; expect = 2 } }) + fail { loc; msg = Number_arguments { has = List.length pats; expect = 2 } } | Ctuple, pats -> let@ bts = match BT.is_tuple_bt bt with | Some bts when List.length bts == List.length pats -> return bts | _ -> - fail (fun _ -> + fail { loc; msg = Generic @@ -1444,7 +1599,7 @@ module BaseTyping = struct (Int.to_string (List.length pats) ^ "-length tuple pattern match against") (BT.pp bt)) - }) + } in let@ pats = ListM.map2M check_and_bind_pattern bts pats in return (Mu.Ctuple, pats) @@ -1499,12 +1654,12 @@ module BaseTyping = struct if BT.fits_range (Option.get (BT.is_bits_bt bt)) z then return (Mu.OV (bt, OVinteger iv)) else - fail (fun _ -> + fail { loc; msg = Generic (!^"Value " ^^^ Pp.z z ^^^ !^"does not fit in expected type" ^^^ BT.pp bt) - }) + } | _ -> let@ ov = infer_object_value loc ov_original in let@ () = ensure_base_type loc ~expect:bt (Mu.bt_of_object_value ov) in @@ -1575,9 +1730,7 @@ module BaseTyping = struct let rec infer_pexpr : 'TY. 'TY Mu.pexpr -> BT.t Mu.pexpr m = fun pe -> let open Mu in - Pp.debug - 22 - (lazy (Pp.item "WellTyped.BaseTyping.infer_pexpr" (Pp_mucore_ast.pp_pexpr pe))); + Pp.debug 22 (lazy (Pp.item __FUNCTION__ (Pp_mucore_ast.pp_pexpr pe))); let (Pexpr (loc, annots, _, pe_)) = pe in match integer_annot annots with | Some ity when !use_ity -> @@ -1703,8 +1856,8 @@ module BaseTyping = struct let@ () = ensure_base_type loc ~expect:(List ibt) (bt_of_pexpr xs) in return (bt_of_pexpr xs) | _ -> - fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pes; expect = 2 } })) + fail + { loc; msg = Number_arguments { has = List.length pes; expect = 2 } }) | Ctuple -> return (BT.Tuple (List.map bt_of_pexpr pes)) | Carray -> let ibt = bt_of_pexpr (List.hd pes) in @@ -1796,21 +1949,21 @@ module BaseTyping = struct let@ () = ensure_bits_type loc bt in return bt | None, _ -> - fail (fun _ -> + fail { loc; msg = Generic (Pp.item "untypeable mucore function" (Pp_mucore_ast.pp_pexpr orig_pe)) - }) + } | Some `Returns_Integer, None -> - fail (fun _ -> + fail { loc; msg = Generic (Pp.item "mucore function requires type-annotation" (Pp_mucore_ast.pp_pexpr orig_pe)) - }) + } in return (bt, pexps) @@ -1819,10 +1972,7 @@ module BaseTyping = struct let open Cnprog in Pp.debug 22 - (lazy - (Pp.item - "WellTyped.check_cn_statement" - (CF.Pp_ast.pp_doc_tree (dtree_of_statement stmt)))); + (lazy (Pp.item __FUNCTION__ (CF.Pp_ast.pp_doc_tree (dtree_of_statement stmt)))); match stmt with | Pack_unpack (pack_unpack, pt) -> let@ p_pt = WReq.welltyped loc (P pt) in @@ -1886,7 +2036,7 @@ module BaseTyping = struct let wrong_number_arguments () = let has = List.length its in let expect = AT.count_computational lemma_typ in - fail (fun _ -> { loc; msg = Number_arguments { has; expect } }) + fail { loc; msg = Number_arguments { has; expect } } in let rec check_args lemma_typ its = match (lemma_typ, its) with @@ -1935,9 +2085,7 @@ module BaseTyping = struct let rec infer_expr : 'TY. label_context -> 'TY Mu.expr -> BT.t Mu.expr m = fun label_context e -> let open Mu in - Pp.debug - 22 - (lazy (Pp.item "WellTyped.BaseTyping.infer_expr" (Pp_mucore_ast.pp_expr e))); + Pp.debug 22 (lazy (Pp.item __FUNCTION__ (Pp_mucore_ast.pp_expr e))); let (Expr (loc, annots, _, e_)) = e in match integer_annot annots with | Some ity when !use_ity -> @@ -2062,12 +2210,12 @@ module BaseTyping = struct assert (not is_variadic); return (snd ret_v_ct, List.map fst arg_r_cts) | _ -> - fail (fun _ -> + fail { loc; msg = Generic (Pp.item "not a function pointer at call-site" (Sctypes.pp act.ct)) - }) + } in let@ f_pe = check_pexpr (Loc ()) f_pe in (* TODO: we'd have to check the arguments against the function type, but we @@ -2116,16 +2264,14 @@ module BaseTyping = struct (* copying from check.ml *) let@ lt, _lkind = match Sym.Map.find_opt l label_context with - | None -> - fail (fun _ -> - { loc; msg = Generic (!^"undefined code label" ^/^ Sym.pp l) }) + | None -> fail { loc; msg = Generic (!^"undefined code label" ^/^ Sym.pp l) } | Some (lt, lkind, _) -> return (lt, lkind) in let@ pes = let wrong_number_arguments () = let has = List.length pes in let expect = AT.count_computational lt in - fail (fun _ -> { loc; msg = Number_arguments { has; expect } }) + fail { loc; msg = Number_arguments { has; expect } } in let rec check_args lt pes = match (lt, pes) with @@ -2173,16 +2319,23 @@ module BaseTyping = struct end module WLabel = struct - open Mu + open Mucore let typ l = WArgs.typ (fun _body -> False.False) l + let consistent (loc : Loc.t) (lt : _ expr arguments) : unit m = + WArgs.consistent (fun _loc _body -> return ()) "loop/label" loc lt + + let welltyped (loc : Loc.t) (lt : _ expr arguments) : _ expr arguments m = WArgs.welltyped (fun _loc body -> return body) "loop/label" loc lt end module WProc = struct - open Mu + module AT = ArgumentTypes + module LAT = LogicalArgumentTypes + module Mu = Mucore + open Mucore let label_context function_rt label_defs = Pmap.fold @@ -2205,9 +2358,42 @@ module WProc = struct let typ p = WArgs.typ (fun (_body, _labels, rt) -> rt) p + let consistent : Loc.t -> _ Mu.args_and_body -> unit m = + fun (loc : Loc.t) (at : 'TY1 Mu.args_and_body) -> + WArgs.consistent + (fun loc (_body, labels, rt) -> + let@ () = pure_and_no_initial_resources loc (WRT.consistent loc rt) in + let@ () = + PmapM.iterM + (fun _sym def -> + match def with + | Return _ -> return () + | Label (loc, label_args_and_body, _annots, _parsed_spec, _loop_info) -> + pure_and_no_initial_resources + loc + (WLabel.consistent loc label_args_and_body)) + labels + in + PmapM.iterM + (fun _sym def -> + match def with + | Return _ -> return () + | Label (loc, label_args_and_body, _annots, _parsed_spec, _loop_info) -> + pure_and_no_initial_resources + loc + (WArgs.consistent + (fun _loc _label_body -> return ()) + "label" + loc + label_args_and_body)) + labels) + "function" + loc + at + + let welltyped : Loc.t -> _ Mu.args_and_body -> _ Mu.args_and_body m = fun (loc : Loc.t) (at : 'TY1 Mu.args_and_body) -> - Pp.(debug 6 (lazy !^__LOC__)); WArgs.welltyped (fun loc (body, labels, rt) -> let@ rt = pure_and_no_initial_resources loc (WRT.welltyped loc rt) in @@ -2255,6 +2441,45 @@ module WProc = struct end module WRPD = struct + module Def = Definition + module LC = LogicalConstraints + + let consistent Def.Predicate.{ loc; pointer; iargs; oarg_bt = _; clauses } = + let open Typing in + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + pure + (let@ () = add_l pointer BT.(Loc ()) (loc, lazy (Pp.string "ptr-var")) in + let@ () = + ListM.iterM (fun (s, bt) -> add_l s bt (loc, lazy (Pp.string "input-var"))) iargs + in + match clauses with + | None -> return () + | Some clauses -> + let@ _ = + ListM.fold_leftM + (fun acc Def.Clause.{ loc; guard; packing_ft } -> + let here = Locations.other __LOC__ in + let negated_guards = + List.map (fun clause -> IT.not_ clause.Def.Clause.guard here) acc + in + pure + (let@ () = add_c loc (LC.T guard) in + let@ () = add_c loc (LC.T (IT.and_ negated_guards here)) in + let@ () = + WLAT.consistent + (fun _loc _it -> return ()) + IT.pp + "clause" + loc + packing_ft + in + return (acc @ [ Def.Clause.{ loc; guard; packing_ft } ]))) + [] + clauses + in + return ()) + + let welltyped Def.Predicate.{ loc; pointer; iargs; oarg_bt; clauses } = (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure @@ -2276,14 +2501,8 @@ module WRPD = struct ListM.fold_leftM (fun acc Def.Clause.{ loc; guard; packing_ft } -> let@ guard = WIT.check loc BT.Bool guard in - let here = Locations.other __LOC__ in - let negated_guards = - List.map (fun clause -> IT.not_ clause.Def.Clause.guard here) acc - in pure - (let@ () = add_c loc (LC.T guard) in - let@ () = add_c loc (LC.T (IT.and_ negated_guards here)) in - let@ packing_ft = + (let@ packing_ft = WLAT.welltyped (fun loc it -> WIT.check loc oarg_bt it) IT.pp @@ -2329,17 +2548,26 @@ module WLFD = struct end module WLemma = struct + let consistent loc _lemma_s lemma_typ = + WAT.consistent + (fun loc lrt -> pure_and_no_initial_resources loc (WLRT.consistent loc lrt)) + LogicalReturnTypes.pp + "lemma" + loc + lemma_typ + + let welltyped loc _lemma_s lemma_typ = WAT.welltyped (fun loc lrt -> pure_and_no_initial_resources loc (WLRT.welltyped loc lrt)) - LRT.pp + LogicalReturnTypes.pp "lemma" loc lemma_typ end module WDT = struct - open Mu + open Mucore let welltyped (dt_name, { loc; cases }) = let@ _ = @@ -2434,7 +2662,7 @@ module WDT = struct ^/^ !^"Indirect recursion via map, set, record," ^^^ !^"or tuple types is not permitted." in - fail (fun _ -> { loc; msg = Generic err })) + fail { loc; msg = Generic err }) args) cases) scc) diff --git a/tests/cn/implies3.error.c.verify b/tests/cn/implies3.error.c.verify index 6958a7939..2d7b1bede 100644 --- a/tests/cn/implies3.error.c.verify +++ b/tests/cn/implies3.error.c.verify @@ -1,5 +1,5 @@ return code: 1 -tests/cn/implies3.error.c:1:1: error: function makes inconsistent assumptions +tests/cn/implies3.error.c:1:1: error: proc/fun makes inconsistent assumptions int foo () ~~~~^~~~~~ State file: file:///tmp/state__implies3.error.c.html diff --git a/tests/cn/inconsistent.error.c.verify b/tests/cn/inconsistent.error.c.verify index 29136eb38..d0a2acb96 100644 --- a/tests/cn/inconsistent.error.c.verify +++ b/tests/cn/inconsistent.error.c.verify @@ -1,5 +1,5 @@ return code: 1 -tests/cn/inconsistent.error.c:1:1: error: function makes inconsistent assumptions +tests/cn/inconsistent.error.c:1:1: error: proc/fun makes inconsistent assumptions void f() ~~~~~^~~ State file: file:///tmp/state__inconsistent.error.c.html diff --git a/tests/cn/inconsistent2.error.c.verify b/tests/cn/inconsistent2.error.c.verify index 125c67455..845303060 100644 --- a/tests/cn/inconsistent2.error.c.verify +++ b/tests/cn/inconsistent2.error.c.verify @@ -2,6 +2,9 @@ return code: 1 tests/cn/inconsistent2.error.c:9:19: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. /*@ requires take f1 = each(i32 i; 0i32 <= i && i <= 0i32) { False(p + i, i) }; ^ +tests/cn/inconsistent2.error.c:12:22: warning: 'extract' expects a 'u64', but '0'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract False, 0i32; @*/ + ^ tests/cn/inconsistent2.error.c:8:1: error: return type makes inconsistent assumptions void f (int *p) ~~~~~^~~~~~~~~~ From 0bb93bf2adb99ba357f86b5d7ead1b55ca340e3a Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sat, 28 Dec 2024 23:15:43 +0000 Subject: [PATCH 130/148] CN: Re-add label consistency check PR #797 split out the consistency and welltyped checks for a few constructs, but accidentally removed the consistency checks for labels. This commit adds them back. This commit also deletes some code which was made redundant by aba34a0, but was not deleted in that commit. --- backend/cn/lib/check.ml | 5 +++++ backend/cn/lib/wellTyped.ml | 35 ----------------------------------- tests/cn/memcpy.c.verify | 6 ------ 3 files changed, 5 insertions(+), 41 deletions(-) diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 6ad4c8778..14051f148 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -2669,6 +2669,11 @@ let time_check_c_functions (global_var_constraints, (checked : c_function list)) global.fun_decls (return ()) in + let@ () = + ListM.iterM + (fun (_, (loc, args_and_body)) -> WellTyped.WProc.consistent loc args_and_body) + checked + in let@ errors = check_c_functions checked in Cerb_debug.end_csv_timing "type checking functions"; return errors diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 981ade6b8..4a0940003 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -2319,16 +2319,7 @@ module BaseTyping = struct end module WLabel = struct - open Mucore - let typ l = WArgs.typ (fun _body -> False.False) l - - let consistent (loc : Loc.t) (lt : _ expr arguments) : unit m = - WArgs.consistent (fun _loc _body -> return ()) "loop/label" loc lt - - - let welltyped (loc : Loc.t) (lt : _ expr arguments) : _ expr arguments m = - WArgs.welltyped (fun _loc body -> return body) "loop/label" loc lt end module WProc = struct @@ -2363,17 +2354,6 @@ module WProc = struct WArgs.consistent (fun loc (_body, labels, rt) -> let@ () = pure_and_no_initial_resources loc (WRT.consistent loc rt) in - let@ () = - PmapM.iterM - (fun _sym def -> - match def with - | Return _ -> return () - | Label (loc, label_args_and_body, _annots, _parsed_spec, _loop_info) -> - pure_and_no_initial_resources - loc - (WLabel.consistent loc label_args_and_body)) - labels - in PmapM.iterM (fun _sym def -> match def with @@ -2397,21 +2377,6 @@ module WProc = struct WArgs.welltyped (fun loc (body, labels, rt) -> let@ rt = pure_and_no_initial_resources loc (WRT.welltyped loc rt) in - let@ labels = - PmapM.mapM - (fun _sym def -> - match def with - | Return loc -> return (Return loc) - | Label (loc, label_args_and_body, annots, parsed_spec, loop_info) -> - let@ label_args_and_body = - pure_and_no_initial_resources - loc - (WLabel.welltyped loc label_args_and_body) - in - return (Label (loc, label_args_and_body, annots, parsed_spec, loop_info))) - labels - Sym.compare - in let label_context = label_context rt labels in let@ labels = PmapM.mapM diff --git a/tests/cn/memcpy.c.verify b/tests/cn/memcpy.c.verify index 5208f19ec..c354d7b31 100644 --- a/tests/cn/memcpy.c.verify +++ b/tests/cn/memcpy.c.verify @@ -17,12 +17,6 @@ tests/cn/memcpy.c:17:16: warning: 'each' expects a 'u64', but 'j' with type 'i32 tests/cn/memcpy.c:19:16: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. take srcInv = each (i32 j; 0i32 <= j && j < n) ^ -tests/cn/memcpy.c:17:16: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. - /*@ inv take dstInv = each (i32 j; 0i32 <= j && j < n) - ^ -tests/cn/memcpy.c:19:16: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. - take srcInv = each (i32 j; 0i32 <= j && j < n) - ^ tests/cn/memcpy.c:28:30: warning: 'extract' expects a 'u64', but '(i32)read_&i0' with type 'i32' was provided. This will become an error in the future. /*@ extract Owned, (i32)i; @*/ ^~~~~~ From e5b16c445d66da3fe1425f545d2f475ba23ceba0 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sat, 28 Dec 2024 11:14:31 +0000 Subject: [PATCH 131/148] CN: Add WellTyped interface file --- backend/cn/lib/wellTyped.ml | 16 +- backend/cn/lib/wellTyped.mli | 525 +++++++++++++++++++++++++++++++++++ 2 files changed, 531 insertions(+), 10 deletions(-) create mode 100644 backend/cn/lib/wellTyped.mli diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 4a0940003..9382cb3be 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -266,12 +266,9 @@ module WCT = struct end module WIT = struct - module LC = LogicalConstraints open BaseTypes open IndexTerms - type t = IndexTerms.t - (* let rec check_and_bind_pattern loc bt pat = *) (* match pat with *) (* | PSym s -> *) @@ -1225,8 +1222,6 @@ module WLRT = struct end module WRT = struct - let subst = ReturnTypes.subst - let pp = ReturnTypes.pp let consistent loc rt = @@ -1386,11 +1381,13 @@ module WFT = struct WRT.pp end -module WLT = struct - open False +(* + module WLT = struct + open False - let welltyped = WAT.welltyped (fun _loc False -> return False) False.pp -end + let welltyped = WAT.welltyped (fun _loc False -> return False) False.pp + end +*) (* module WPackingFT(struct let name_bts = pd.oargs end) = WLAT(WOutputDef.welltyped (pd.oargs)) *) @@ -1528,7 +1525,6 @@ end module BaseTyping = struct open TypeErrors module BT = BaseTypes - module RT = ReturnTypes module AT = ArgumentTypes open BT diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli new file mode 100644 index 000000000..74e13cbe3 --- /dev/null +++ b/backend/cn/lib/wellTyped.mli @@ -0,0 +1,525 @@ +(* module CF = Cerb_frontend *) +(* module BT = BaseTypes *) +(* module IT = IndexTerms *) +(* module Loc = Locations *) +module IdSet : Set.S with type elt = Id.t + +(* val squotes : Pp.document -> Pp.document *) +(* val warn : Locations.t -> Pp.document -> unit *) +(* val dot : Pp.document *) +(* val string : string -> Pp.document *) +(* val debug : int -> Pp.document Lazy.t -> unit *) +(* val item : string -> Pp.document -> Pp.document *) +(* val colon : Pp.document *) +(* val comma : Pp.document *) +module type NoSolver = sig + type 'a m = 'a Typing.t + + type failure = Context.t * Explain.log -> TypeErrors.t + + val pure : 'a m -> 'a m + + val fail : failure -> 'a m + + val bound_a : Sym.t -> bool m + + val bound_l : Sym.t -> bool m + + val get_a : Sym.t -> Context.basetype_or_value m + + val get_l : Sym.t -> Context.basetype_or_value m + + val add_a : Sym.t -> BaseTypes.t -> Context.l_info -> unit m + + val add_l : Sym.t -> BaseTypes.t -> Context.l_info -> unit m + + val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_layout m + + val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.ctype m + + val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info m + + val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info m + + val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t m + + val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t m + + val get_lemma : Locations.t -> Sym.t -> (Locations.t * ArgumentTypes.lemmat) m + + val get_fun_decl + : Locations.t -> + Sym.t -> + (Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) m + + val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit m + + val lift : 'a Or_TypeError.t -> 'a m +end + +(* val fail : TypeErrors.t -> 'a Typing.t *) +val use_ity : bool ref + +(* val illtyped_index_term : *) +(* Locations.t -> *) +(* 'a IT.annot -> *) +(* unit BT.t_gen -> *) +(* expected:string -> *) +(* reason:(Locations.t, string) Either.either -> TypeErrors.t *) +(* (* keep *) *) +val ensure_bits_type : Locations.t -> BaseTypes.t -> unit Typing.t + +(* val ensure_z_fits_bits_type : *) +(* Locations.t -> BT.sign * int -> Z.t -> unit Typing.t *) +(* val ensure_arith_type : *) +(* reason:Locations.t -> unit BT.t_gen IT.annot -> unit Typing.t *) +(* val ensure_set_type : *) +(* reason:Locations.t -> *) +(* unit BT.t_gen IT.annot -> unit BT.t_gen Typing.t *) +(* val ensure_list_type : *) +(* reason:Locations.t -> *) +(* unit BT.t_gen IT.annot -> unit BT.t_gen Typing.t *) +(* val ensure_map_type : *) +(* reason:Locations.t -> *) +(* unit BT.t_gen IT.annot -> (unit BT.t_gen * unit BT.t_gen) Typing.t *) +(* keep *) +val ensure_same_argument_number + : Locations.t -> + [< `General | `Input | `Output ] -> + int -> + expect:int -> + unit Typing.t +(* keep *) + +val compare_by_fst_id : Id.t * 'a -> Id.t * 'b -> int + +(* val correct_members : *) +(* Locations.t -> *) +(* (Id.t * 'a) list -> (Id.t * 'b) list -> unit Typing.t *) +(* val correct_members_sorted_annotated : *) +(* Locations.t -> *) +(* (Id.t * 'a) list -> *) +(* (Id.t * 'b) list -> ('a * (Id.t * 'b)) list Typing.t *) +(* module WBT : *) +(* sig *) +(* val is_bt : Locations.t -> unit BT.t_gen -> unit BT.t_gen Typing.t *) +(* val pick_integer_encoding_type : *) +(* Locations.t -> Z.t -> 'a BT.t_gen Typing.t *) +(* end *) +module WCT : (* keep *) sig + val is_ct : Locations.t -> Sctypes.ctype -> unit Typing.t +end + +module WIT : sig + (* module LC = LogicalConstraints *) + (* type t = IndexTerms.t *) + (* val check_and_bind_pattern : *) + (* BT.t -> *) + (* 'a IndexTerms.pattern -> BT.t IndexTerms.pattern Typing.t *) + (* val leading_sym_or_wild : 'a IndexTerms.pattern list -> bool *) + (* val expand_constr : *) + (* Sym.S.sym * IndexTerms.BT.constr_info -> *) + (* IndexTerms.BT.t IndexTerms.pattern list -> *) + (* IndexTerms.BT.t IndexTerms.pattern list option *) + (* val cases_complete : *) + (* Locations.t -> *) + (* IndexTerms.BT.t list -> *) + (* IndexTerms.BT.t IndexTerms.pattern list list -> unit Typing.t *) + (* val cases_necessary : 'a IndexTerms.pattern list -> unit Typing.t *) + (* val get_location_for_type : *) + (* 'a IndexTerms.annot -> Locations.t Typing.t *) + (* keep *) + val infer : 'bt IndexTerms.annot -> IndexTerms.t Typing.t + (* keep *) + + val check : Locations.t -> BaseTypes.t -> 'bt IndexTerms.annot -> IndexTerms.t Typing.t +end +(* keep *) + +val quantifier_bt : 'a BaseTypes.t_gen + +(* val warn_when_not_quantifier_bt : *) +(* string -> Locations.t -> BaseTypes.t -> Pp.document option -> unit *) +(* module WReq : *) +(* sig *) +(* module Req = Request *) +(* val welltyped : Locations.t -> Req.t -> Req.t Typing.t *) +(* end *) +module WRS : sig + (* keep *) + val oarg_bt_of_pred : Locations.t -> Request.name -> BaseTypes.t Typing.t + (* val oarg_bt : *) + (* Locations.t -> Request.t -> unit Memory.BT.t_gen Typing.t *) + (* val welltyped : *) + (* Locations.t -> *) + (* WReq.Req.t * unit BT.t_gen -> (WReq.Req.t * unit BT.t_gen) Typing.t *) +end + +module WLC : sig + (* module LC = LogicalConstraints *) + (* keep *) + val welltyped : Locations.t -> LogicalConstraints.t -> LogicalConstraints.t Typing.t +end + +(* module WLRT : *) +(* sig *) +(* module LC = LogicalConstraints *) +(* module LRT = LogicalReturnTypes *) +(* val consistent : Locations.t -> LRT.t -> unit Typing.m *) +(* val welltyped : 'a -> LRT.t -> LRT.t Typing.t *) +(* end *) +(* module WRT : *) +(* sig *) +(* val subst : *) +(* [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> *) +(* ReturnTypes.t -> ReturnTypes.t *) +(* val pp : ReturnTypes.t -> Pp.document *) +(* val consistent : Locations.t -> ReturnTypes.t -> unit Typing.t *) +(* val welltyped : 'a -> ReturnTypes.t -> ReturnTypes.t Typing.t *) +(* end *) +(* val pure_and_no_initial_resources : *) +(* Locations.t -> 'a Typing.m -> 'a Typing.m *) +(* module WLAT : *) +(* sig *) +(* module LC = LogicalConstraints *) +(* module LAT = LogicalArgumentTypes *) +(* val consistent : *) +(* (Locations.t -> 'i -> unit Typing.m) -> *) +(* ('i -> Pp.document) -> *) +(* string -> Locations.t -> 'i LAT.t -> unit Typing.t *) +(* val welltyped : *) +(* (Locations.t -> 'i -> 'i Typing.t) -> *) +(* ('i -> Pp.document) -> *) +(* string -> Locations.t -> 'i LAT.t -> 'i LAT.t Typing.t *) +(* end *) +(* module WAT : *) +(* sig *) +(* module AT = ArgumentTypes *) +(* val consistent : *) +(* (Locations.t -> 'i -> unit Typing.m) -> *) +(* ('i -> Pp.document) -> *) +(* string -> Locations.t -> 'i AT.t -> unit Typing.t *) +(* val welltyped : *) +(* (Locations.t -> 'i -> 'i Typing.t) -> *) +(* ('i -> Pp.document) -> *) +(* string -> Locations.t -> 'i AT.t -> 'i AT.t Typing.t *) +(* end *) +module WFT : sig + (* keep *) + val consistent : string -> Locations.t -> ReturnTypes.t ArgumentTypes.t -> unit Typing.t + + (* keep *) + val welltyped + : string -> + Locations.t -> + ReturnTypes.t ArgumentTypes.t -> + ReturnTypes.t ArgumentTypes.t Typing.t +end + +(* module WLT : *) +(* sig *) +(* val welltyped : *) +(* string -> *) +(* Locations.t -> False.t WAT.AT.t -> False.t WAT.AT.t Typing.t *) +(* end *) +(* module WLArgs : *) +(* sig *) +(* module LC = LogicalConstraints *) +(* module LAT = LogicalArgumentTypes *) +(* module Mu = Mucore *) +(* val typ : ('a -> 'b) -> 'a Mu.arguments_l -> 'b LAT.t *) +(* val consistent : *) +(* (Locations.t -> 'i -> unit Typing.t) -> *) +(* string -> Locations.t -> 'i Mu.arguments_l -> unit Typing.t *) +(* val welltyped : *) +(* (Locations.t -> 'i -> 'j Typing.t) -> *) +(* 'a -> Locations.t -> 'i Mu.arguments_l -> 'j Mu.arguments_l Typing.t *) +(* end *) +(* module WArgs : *) +(* sig *) +(* module AT = ArgumentTypes *) +(* module Mu = Mucore *) +(* val typ : ('a -> 'b) -> 'a Mu.arguments -> 'b AT.t *) +(* val consistent : *) +(* (Locations.t -> 'i -> unit Typing.t) -> *) +(* string -> Locations.t -> 'i Mu.arguments -> unit Typing.t *) +(* val welltyped : *) +(* (Locations.t -> 'i -> 'j Typing.t) -> *) +(* string -> Locations.t -> 'i Mu.arguments -> 'j Mu.arguments Typing.t *) +(* end *) +module BaseTyping : sig + (* module BT = BaseTypes *) + (* module RT = ReturnTypes *) + (* module AT = ArgumentTypes *) + (* keep *) + type label_context = (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t + + (* val check_against_core_bt : *) + (* Locations.t -> *) + (* Cn__Pp.document -> *) + (* Cerb_frontend.Core.core_base_type -> *) + (* unit CoreTypeChecks.BT.t_gen -> unit Typing.t *) + (* module Mu = Mucore *) + (* val check_and_bind_pattern : *) + (* unit CoreTypeChecks.BT.t_gen -> *) + (* 'a Mu.pattern -> unit CoreTypeChecks.BT.t_gen Mu.pattern Typing.t *) + (* val check_and_bind_pattern_ : *) + (* unit CoreTypeChecks.BT.t_gen -> *) + (* Locations.t -> *) + (* 'a Mu.pattern_ -> *) + (* unit CoreTypeChecks.BT.t_gen Mu.pattern_ Typing.t *) + (* val infer_object_value : *) + (* Locations.t -> *) + (* 'TY Mu.object_value -> BT.t Mu.object_value Typing.t *) + (* val check_object_value : *) + (* Locations.t -> *) + (* BT.t -> 'TY Mu.object_value -> BT.t Mu.object_value Typing.t *) + (* val infer_value : *) + (* Locations.t -> 'TY Mu.value -> BT.t Mu.value Typing.t *) + (* val check_value : *) + (* Locations.t -> BT.t -> 'TY Mu.value -> BT.t Mu.value Typing.t *) + (* val is_integer_annot : *) + (* Cerb_frontend.Annot.annot -> Cerb_frontend.IntegerType.integerType option *) + (* keep *) + val integer_annot + : Cerb_frontend.Annot.annot list -> + Cerb_frontend.IntegerType.integerType option + + (* val remove_integer_annot : Cerb_frontend.Annot.annot list -> Cerb_frontend.Annot.annot list *) + (* val remove_integer_annot_expr : 'a Mu.expr -> 'a Mu.expr *) + (* val remove_integer_annot_pexpr : 'a Mu.pexpr -> 'a Mu.pexpr *) + (* val infer_pexpr : 'TY Mu.pexpr -> BT.t Mu.pexpr Typing.t *) + (* val check_pexpr : BT.t -> 'TY Mu.pexpr -> BT.t Mu.pexpr Typing.t *) + (* val check_infer_apply_fun : *) + (* BT.t option -> *) + (* Mu.mu_function -> *) + (* 'TY Mu.pexpr list -> *) + (* 'TY Mu.pexpr -> (BaseTypes.t * BT.t Mu.pexpr list) Typing.t *) + (* val check_cn_statement : *) + (* Locations.t -> Cnprog.statement -> Cnprog.statement Typing.t *) + (* val check_cnprog : Cnprog.t -> Cnprog.t Typing.t *) + (* val signed_int_ty : unit Memory.BT.t_gen *) + (* keep *) + val infer_expr : label_context -> 'TY Mucore.expr -> BaseTypes.t Mucore.expr Typing.t + + val check_expr + : label_context -> + BaseTypes.t -> + 'TY Mucore.expr -> + BaseTypes.t Mucore.expr Typing.t +end + +(* module WLabel : *) +(* sig *) +(* val typ : 'a WArgs.Mu.arguments -> False.t WArgs.AT.t *) +(* val consistent : *) +(* Locations.t -> 'a Mucore.expr Mucore.arguments -> unit Typing.t *) +(* val welltyped : *) +(* Locations.t -> *) +(* 'a Mucore.expr Mucore.arguments -> *) +(* 'a Mucore.expr Mucore.arguments Typing.t *) +(* end *) +module WProc : sig + (* module AT = ArgumentTypes *) + (* module LAT = LogicalArgumentTypes *) + (* module Mu = Mucore *) + val label_context + : ReturnTypes.t -> + (Sym.Map.key, 'a Mucore.label_def) Pmap.map -> + (False.t ArgumentTypes.t * Cerb_frontend.Annot.label_annot * Locations.t) Sym.Map.t + (* keep *) + + val typ : ('a * 'b * 'c) Mucore.arguments -> 'c ArgumentTypes.t + + (* keep *) + val consistent : Locations.t -> 'TY1 Mucore.args_and_body -> unit Typing.t + + (* keep *) + val welltyped + : Locations.t -> + 'TY1 Mucore.args_and_body -> + BaseTypes.t Mucore.args_and_body Typing.t +end + +module WRPD : sig + (* module Def = Definition *) + (* module LC = LogicalConstraints *) + (* keep *) + val consistent : Definition.Predicate.t -> unit Typing.m + + val welltyped : Definition.Predicate.t -> Definition.Predicate.t Typing.t +end + +module WLFD : sig + (* keep *) + val welltyped : Definition.Function.t -> Definition.Function.t Typing.t +end + +module WLemma : (* keep *) + sig + val consistent + : Locations.t -> + 'a -> + LogicalReturnTypes.t ArgumentTypes.t -> + unit Typing.t + + val welltyped + : Locations.t -> + 'a -> + LogicalReturnTypes.t ArgumentTypes.t -> + LogicalReturnTypes.t ArgumentTypes.t Typing.t +end + +module WDT : sig + (* keep *) + val welltyped : 'a * Mucore.datatype -> ('a * Mucore.datatype) Typing.t + + module G : sig + type t = Graph__Persistent.Digraph.Concrete(Sym).t + + module V : sig + type t = Sym.t + + val compare : t -> t -> int + + val hash : t -> int + + val equal : t -> t -> bool + + type label = Sym.t + + val create : label -> t + + val label : t -> label + end + + type vertex = V.t + + module E : sig + type t = Sym.t * Sym.t + + val compare : t -> t -> int + + type nonrec vertex = vertex + + val src : t -> vertex + + val dst : t -> vertex + + type label = unit + + val create : vertex -> label -> vertex -> t + + val label : t -> label + end + + type edge = E.t + + val is_directed : bool + + val is_empty : t -> bool + + val nb_vertex : t -> int + + val nb_edges : t -> int + + val out_degree : t -> vertex -> int + + val in_degree : t -> vertex -> int + + val mem_vertex : t -> vertex -> bool + + val mem_edge : t -> vertex -> vertex -> bool + + val mem_edge_e : t -> edge -> bool + + val find_edge : t -> vertex -> vertex -> edge + + val find_all_edges : t -> vertex -> vertex -> edge list + + val succ : t -> vertex -> vertex list + + val pred : t -> vertex -> vertex list + + val succ_e : t -> vertex -> edge list + + val pred_e : t -> vertex -> edge list + + val iter_vertex : (vertex -> unit) -> t -> unit + + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + + val iter_edges : (vertex -> vertex -> unit) -> t -> unit + + val fold_edges : (vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a + + val iter_edges_e : (edge -> unit) -> t -> unit + + val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a + + val map_vertex : (vertex -> vertex) -> t -> t + + val iter_succ : (vertex -> unit) -> t -> vertex -> unit + + val iter_pred : (vertex -> unit) -> t -> vertex -> unit + + val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val fold_pred : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val iter_succ_e : (edge -> unit) -> t -> vertex -> unit + + val fold_succ_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val iter_pred_e : (edge -> unit) -> t -> vertex -> unit + + val fold_pred_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + + val empty : t + + val add_vertex : t -> vertex -> t + + val remove_vertex : t -> vertex -> t + + val add_edge : t -> vertex -> vertex -> t + + val add_edge_e : t -> edge -> t + + val remove_edge : t -> vertex -> vertex -> t + + val remove_edge_e : t -> edge -> t + end + + (* val bts_in_dt_constructor_argument : 'a * 'b BT.t_gen -> 'b BT.t_gen list *) + (* val bts_in_dt_case : 'a * ('b * 'c BT.t_gen) list -> 'c BT.t_gen list *) + (* val bts_in_dt_definition : Mucore.datatype -> unit BT.t_gen list *) + (* val dts_in_dt_definition : Mucore.datatype -> Sym.t list *) + (* keep *) + val check_recursion_ok : (Sym.S.sym * Mucore.datatype) list -> G.V.t list list Typing.t +end +(* + BaseTyping.infer_expr + BaseTyping.integer_annot + WCT.is_ct + WDT.check_recursion_ok + WDT.welltyped + WFT.consistent + WFT.welltyped + WIT.check + WIT.infer + WLC.welltyped + WLFD.welltyped + WLemma.consistent + WLemma.welltyped + WProc.label_context + WProc.typ + WProc.welltyped + WRPD.consistent + WRPD.welltyped + WRS.oarg_bt_of_pred + compare_by_fst_id. + ensure_bits_type. + ensure_same_argument_number. + infer. + quantifier_bt. +*) From e601caa0c06d49ed886887dc16b3274e6e4ba738 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sat, 28 Dec 2024 11:19:11 +0000 Subject: [PATCH 132/148] CN: Remove commented lines in wellTyped.mli --- backend/cn/lib/wellTyped.mli | 257 ----------------------------------- 1 file changed, 257 deletions(-) diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index 74e13cbe3..3d10be0c3 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -1,17 +1,5 @@ -(* module CF = Cerb_frontend *) -(* module BT = BaseTypes *) -(* module IT = IndexTerms *) -(* module Loc = Locations *) module IdSet : Set.S with type elt = Id.t -(* val squotes : Pp.document -> Pp.document *) -(* val warn : Locations.t -> Pp.document -> unit *) -(* val dot : Pp.document *) -(* val string : string -> Pp.document *) -(* val debug : int -> Pp.document Lazy.t -> unit *) -(* val item : string -> Pp.document -> Pp.document *) -(* val colon : Pp.document *) -(* val comma : Pp.document *) module type NoSolver = sig type 'a m = 'a Typing.t @@ -57,158 +45,42 @@ module type NoSolver = sig val lift : 'a Or_TypeError.t -> 'a m end -(* val fail : TypeErrors.t -> 'a Typing.t *) val use_ity : bool ref -(* val illtyped_index_term : *) -(* Locations.t -> *) -(* 'a IT.annot -> *) -(* unit BT.t_gen -> *) -(* expected:string -> *) -(* reason:(Locations.t, string) Either.either -> TypeErrors.t *) -(* (* keep *) *) val ensure_bits_type : Locations.t -> BaseTypes.t -> unit Typing.t -(* val ensure_z_fits_bits_type : *) -(* Locations.t -> BT.sign * int -> Z.t -> unit Typing.t *) -(* val ensure_arith_type : *) -(* reason:Locations.t -> unit BT.t_gen IT.annot -> unit Typing.t *) -(* val ensure_set_type : *) -(* reason:Locations.t -> *) -(* unit BT.t_gen IT.annot -> unit BT.t_gen Typing.t *) -(* val ensure_list_type : *) -(* reason:Locations.t -> *) -(* unit BT.t_gen IT.annot -> unit BT.t_gen Typing.t *) -(* val ensure_map_type : *) -(* reason:Locations.t -> *) -(* unit BT.t_gen IT.annot -> (unit BT.t_gen * unit BT.t_gen) Typing.t *) -(* keep *) val ensure_same_argument_number : Locations.t -> [< `General | `Input | `Output ] -> int -> expect:int -> unit Typing.t -(* keep *) val compare_by_fst_id : Id.t * 'a -> Id.t * 'b -> int -(* val correct_members : *) -(* Locations.t -> *) -(* (Id.t * 'a) list -> (Id.t * 'b) list -> unit Typing.t *) -(* val correct_members_sorted_annotated : *) -(* Locations.t -> *) -(* (Id.t * 'a) list -> *) -(* (Id.t * 'b) list -> ('a * (Id.t * 'b)) list Typing.t *) -(* module WBT : *) -(* sig *) -(* val is_bt : Locations.t -> unit BT.t_gen -> unit BT.t_gen Typing.t *) -(* val pick_integer_encoding_type : *) -(* Locations.t -> Z.t -> 'a BT.t_gen Typing.t *) -(* end *) module WCT : (* keep *) sig val is_ct : Locations.t -> Sctypes.ctype -> unit Typing.t end module WIT : sig - (* module LC = LogicalConstraints *) - (* type t = IndexTerms.t *) - (* val check_and_bind_pattern : *) - (* BT.t -> *) - (* 'a IndexTerms.pattern -> BT.t IndexTerms.pattern Typing.t *) - (* val leading_sym_or_wild : 'a IndexTerms.pattern list -> bool *) - (* val expand_constr : *) - (* Sym.S.sym * IndexTerms.BT.constr_info -> *) - (* IndexTerms.BT.t IndexTerms.pattern list -> *) - (* IndexTerms.BT.t IndexTerms.pattern list option *) - (* val cases_complete : *) - (* Locations.t -> *) - (* IndexTerms.BT.t list -> *) - (* IndexTerms.BT.t IndexTerms.pattern list list -> unit Typing.t *) - (* val cases_necessary : 'a IndexTerms.pattern list -> unit Typing.t *) - (* val get_location_for_type : *) - (* 'a IndexTerms.annot -> Locations.t Typing.t *) - (* keep *) val infer : 'bt IndexTerms.annot -> IndexTerms.t Typing.t - (* keep *) val check : Locations.t -> BaseTypes.t -> 'bt IndexTerms.annot -> IndexTerms.t Typing.t end -(* keep *) val quantifier_bt : 'a BaseTypes.t_gen -(* val warn_when_not_quantifier_bt : *) -(* string -> Locations.t -> BaseTypes.t -> Pp.document option -> unit *) -(* module WReq : *) -(* sig *) -(* module Req = Request *) -(* val welltyped : Locations.t -> Req.t -> Req.t Typing.t *) -(* end *) module WRS : sig - (* keep *) val oarg_bt_of_pred : Locations.t -> Request.name -> BaseTypes.t Typing.t - (* val oarg_bt : *) - (* Locations.t -> Request.t -> unit Memory.BT.t_gen Typing.t *) - (* val welltyped : *) - (* Locations.t -> *) - (* WReq.Req.t * unit BT.t_gen -> (WReq.Req.t * unit BT.t_gen) Typing.t *) end module WLC : sig - (* module LC = LogicalConstraints *) - (* keep *) val welltyped : Locations.t -> LogicalConstraints.t -> LogicalConstraints.t Typing.t end -(* module WLRT : *) -(* sig *) -(* module LC = LogicalConstraints *) -(* module LRT = LogicalReturnTypes *) -(* val consistent : Locations.t -> LRT.t -> unit Typing.m *) -(* val welltyped : 'a -> LRT.t -> LRT.t Typing.t *) -(* end *) -(* module WRT : *) -(* sig *) -(* val subst : *) -(* [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> *) -(* ReturnTypes.t -> ReturnTypes.t *) -(* val pp : ReturnTypes.t -> Pp.document *) -(* val consistent : Locations.t -> ReturnTypes.t -> unit Typing.t *) -(* val welltyped : 'a -> ReturnTypes.t -> ReturnTypes.t Typing.t *) -(* end *) -(* val pure_and_no_initial_resources : *) -(* Locations.t -> 'a Typing.m -> 'a Typing.m *) -(* module WLAT : *) -(* sig *) -(* module LC = LogicalConstraints *) -(* module LAT = LogicalArgumentTypes *) -(* val consistent : *) -(* (Locations.t -> 'i -> unit Typing.m) -> *) -(* ('i -> Pp.document) -> *) -(* string -> Locations.t -> 'i LAT.t -> unit Typing.t *) -(* val welltyped : *) -(* (Locations.t -> 'i -> 'i Typing.t) -> *) -(* ('i -> Pp.document) -> *) -(* string -> Locations.t -> 'i LAT.t -> 'i LAT.t Typing.t *) -(* end *) -(* module WAT : *) -(* sig *) -(* module AT = ArgumentTypes *) -(* val consistent : *) -(* (Locations.t -> 'i -> unit Typing.m) -> *) -(* ('i -> Pp.document) -> *) -(* string -> Locations.t -> 'i AT.t -> unit Typing.t *) -(* val welltyped : *) -(* (Locations.t -> 'i -> 'i Typing.t) -> *) -(* ('i -> Pp.document) -> *) -(* string -> Locations.t -> 'i AT.t -> 'i AT.t Typing.t *) -(* end *) module WFT : sig - (* keep *) val consistent : string -> Locations.t -> ReturnTypes.t ArgumentTypes.t -> unit Typing.t - (* keep *) val welltyped : string -> Locations.t -> @@ -216,90 +88,13 @@ module WFT : sig ReturnTypes.t ArgumentTypes.t Typing.t end -(* module WLT : *) -(* sig *) -(* val welltyped : *) -(* string -> *) -(* Locations.t -> False.t WAT.AT.t -> False.t WAT.AT.t Typing.t *) -(* end *) -(* module WLArgs : *) -(* sig *) -(* module LC = LogicalConstraints *) -(* module LAT = LogicalArgumentTypes *) -(* module Mu = Mucore *) -(* val typ : ('a -> 'b) -> 'a Mu.arguments_l -> 'b LAT.t *) -(* val consistent : *) -(* (Locations.t -> 'i -> unit Typing.t) -> *) -(* string -> Locations.t -> 'i Mu.arguments_l -> unit Typing.t *) -(* val welltyped : *) -(* (Locations.t -> 'i -> 'j Typing.t) -> *) -(* 'a -> Locations.t -> 'i Mu.arguments_l -> 'j Mu.arguments_l Typing.t *) -(* end *) -(* module WArgs : *) -(* sig *) -(* module AT = ArgumentTypes *) -(* module Mu = Mucore *) -(* val typ : ('a -> 'b) -> 'a Mu.arguments -> 'b AT.t *) -(* val consistent : *) -(* (Locations.t -> 'i -> unit Typing.t) -> *) -(* string -> Locations.t -> 'i Mu.arguments -> unit Typing.t *) -(* val welltyped : *) -(* (Locations.t -> 'i -> 'j Typing.t) -> *) -(* string -> Locations.t -> 'i Mu.arguments -> 'j Mu.arguments Typing.t *) -(* end *) module BaseTyping : sig - (* module BT = BaseTypes *) - (* module RT = ReturnTypes *) - (* module AT = ArgumentTypes *) - (* keep *) type label_context = (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t - (* val check_against_core_bt : *) - (* Locations.t -> *) - (* Cn__Pp.document -> *) - (* Cerb_frontend.Core.core_base_type -> *) - (* unit CoreTypeChecks.BT.t_gen -> unit Typing.t *) - (* module Mu = Mucore *) - (* val check_and_bind_pattern : *) - (* unit CoreTypeChecks.BT.t_gen -> *) - (* 'a Mu.pattern -> unit CoreTypeChecks.BT.t_gen Mu.pattern Typing.t *) - (* val check_and_bind_pattern_ : *) - (* unit CoreTypeChecks.BT.t_gen -> *) - (* Locations.t -> *) - (* 'a Mu.pattern_ -> *) - (* unit CoreTypeChecks.BT.t_gen Mu.pattern_ Typing.t *) - (* val infer_object_value : *) - (* Locations.t -> *) - (* 'TY Mu.object_value -> BT.t Mu.object_value Typing.t *) - (* val check_object_value : *) - (* Locations.t -> *) - (* BT.t -> 'TY Mu.object_value -> BT.t Mu.object_value Typing.t *) - (* val infer_value : *) - (* Locations.t -> 'TY Mu.value -> BT.t Mu.value Typing.t *) - (* val check_value : *) - (* Locations.t -> BT.t -> 'TY Mu.value -> BT.t Mu.value Typing.t *) - (* val is_integer_annot : *) - (* Cerb_frontend.Annot.annot -> Cerb_frontend.IntegerType.integerType option *) - (* keep *) val integer_annot : Cerb_frontend.Annot.annot list -> Cerb_frontend.IntegerType.integerType option - (* val remove_integer_annot : Cerb_frontend.Annot.annot list -> Cerb_frontend.Annot.annot list *) - (* val remove_integer_annot_expr : 'a Mu.expr -> 'a Mu.expr *) - (* val remove_integer_annot_pexpr : 'a Mu.pexpr -> 'a Mu.pexpr *) - (* val infer_pexpr : 'TY Mu.pexpr -> BT.t Mu.pexpr Typing.t *) - (* val check_pexpr : BT.t -> 'TY Mu.pexpr -> BT.t Mu.pexpr Typing.t *) - (* val check_infer_apply_fun : *) - (* BT.t option -> *) - (* Mu.mu_function -> *) - (* 'TY Mu.pexpr list -> *) - (* 'TY Mu.pexpr -> (BaseTypes.t * BT.t Mu.pexpr list) Typing.t *) - (* val check_cn_statement : *) - (* Locations.t -> Cnprog.statement -> Cnprog.statement Typing.t *) - (* val check_cnprog : Cnprog.t -> Cnprog.t Typing.t *) - (* val signed_int_ty : unit Memory.BT.t_gen *) - (* keep *) val infer_expr : label_context -> 'TY Mucore.expr -> BaseTypes.t Mucore.expr Typing.t val check_expr @@ -309,32 +104,16 @@ module BaseTyping : sig BaseTypes.t Mucore.expr Typing.t end -(* module WLabel : *) -(* sig *) -(* val typ : 'a WArgs.Mu.arguments -> False.t WArgs.AT.t *) -(* val consistent : *) -(* Locations.t -> 'a Mucore.expr Mucore.arguments -> unit Typing.t *) -(* val welltyped : *) -(* Locations.t -> *) -(* 'a Mucore.expr Mucore.arguments -> *) -(* 'a Mucore.expr Mucore.arguments Typing.t *) -(* end *) module WProc : sig - (* module AT = ArgumentTypes *) - (* module LAT = LogicalArgumentTypes *) - (* module Mu = Mucore *) val label_context : ReturnTypes.t -> (Sym.Map.key, 'a Mucore.label_def) Pmap.map -> (False.t ArgumentTypes.t * Cerb_frontend.Annot.label_annot * Locations.t) Sym.Map.t - (* keep *) val typ : ('a * 'b * 'c) Mucore.arguments -> 'c ArgumentTypes.t - (* keep *) val consistent : Locations.t -> 'TY1 Mucore.args_and_body -> unit Typing.t - (* keep *) val welltyped : Locations.t -> 'TY1 Mucore.args_and_body -> @@ -342,16 +121,12 @@ module WProc : sig end module WRPD : sig - (* module Def = Definition *) - (* module LC = LogicalConstraints *) - (* keep *) val consistent : Definition.Predicate.t -> unit Typing.m val welltyped : Definition.Predicate.t -> Definition.Predicate.t Typing.t end module WLFD : sig - (* keep *) val welltyped : Definition.Function.t -> Definition.Function.t Typing.t end @@ -371,7 +146,6 @@ module WLemma : (* keep *) end module WDT : sig - (* keep *) val welltyped : 'a * Mucore.datatype -> ('a * Mucore.datatype) Typing.t module G : sig @@ -490,36 +264,5 @@ module WDT : sig val remove_edge_e : t -> edge -> t end - (* val bts_in_dt_constructor_argument : 'a * 'b BT.t_gen -> 'b BT.t_gen list *) - (* val bts_in_dt_case : 'a * ('b * 'c BT.t_gen) list -> 'c BT.t_gen list *) - (* val bts_in_dt_definition : Mucore.datatype -> unit BT.t_gen list *) - (* val dts_in_dt_definition : Mucore.datatype -> Sym.t list *) - (* keep *) val check_recursion_ok : (Sym.S.sym * Mucore.datatype) list -> G.V.t list list Typing.t end -(* - BaseTyping.infer_expr - BaseTyping.integer_annot - WCT.is_ct - WDT.check_recursion_ok - WDT.welltyped - WFT.consistent - WFT.welltyped - WIT.check - WIT.infer - WLC.welltyped - WLFD.welltyped - WLemma.consistent - WLemma.welltyped - WProc.label_context - WProc.typ - WProc.welltyped - WRPD.consistent - WRPD.welltyped - WRS.oarg_bt_of_pred - compare_by_fst_id. - ensure_bits_type. - ensure_same_argument_number. - infer. - quantifier_bt. -*) From c8b6a7890f45f3db8199abbb7a19cfea17141bd9 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sat, 28 Dec 2024 11:25:23 +0000 Subject: [PATCH 133/148] CN: Simplify graph signature --- backend/cn/lib/wellTyped.mli | 116 +---------------------------------- 1 file changed, 1 insertion(+), 115 deletions(-) diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index 3d10be0c3..4f1e7e7c1 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -148,121 +148,7 @@ end module WDT : sig val welltyped : 'a * Mucore.datatype -> ('a * Mucore.datatype) Typing.t - module G : sig - type t = Graph__Persistent.Digraph.Concrete(Sym).t - - module V : sig - type t = Sym.t - - val compare : t -> t -> int - - val hash : t -> int - - val equal : t -> t -> bool - - type label = Sym.t - - val create : label -> t - - val label : t -> label - end - - type vertex = V.t - - module E : sig - type t = Sym.t * Sym.t - - val compare : t -> t -> int - - type nonrec vertex = vertex - - val src : t -> vertex - - val dst : t -> vertex - - type label = unit - - val create : vertex -> label -> vertex -> t - - val label : t -> label - end - - type edge = E.t - - val is_directed : bool - - val is_empty : t -> bool - - val nb_vertex : t -> int - - val nb_edges : t -> int - - val out_degree : t -> vertex -> int - - val in_degree : t -> vertex -> int - - val mem_vertex : t -> vertex -> bool - - val mem_edge : t -> vertex -> vertex -> bool - - val mem_edge_e : t -> edge -> bool - - val find_edge : t -> vertex -> vertex -> edge - - val find_all_edges : t -> vertex -> vertex -> edge list - - val succ : t -> vertex -> vertex list - - val pred : t -> vertex -> vertex list - - val succ_e : t -> vertex -> edge list - - val pred_e : t -> vertex -> edge list - - val iter_vertex : (vertex -> unit) -> t -> unit - - val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a - - val iter_edges : (vertex -> vertex -> unit) -> t -> unit - - val fold_edges : (vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a - - val iter_edges_e : (edge -> unit) -> t -> unit - - val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a - - val map_vertex : (vertex -> vertex) -> t -> t - - val iter_succ : (vertex -> unit) -> t -> vertex -> unit - - val iter_pred : (vertex -> unit) -> t -> vertex -> unit - - val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - - val fold_pred : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - - val iter_succ_e : (edge -> unit) -> t -> vertex -> unit - - val fold_succ_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - - val iter_pred_e : (edge -> unit) -> t -> vertex -> unit - - val fold_pred_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - - val empty : t - - val add_vertex : t -> vertex -> t - - val remove_vertex : t -> vertex -> t - - val add_edge : t -> vertex -> vertex -> t - - val add_edge_e : t -> edge -> t - - val remove_edge : t -> vertex -> vertex -> t - - val remove_edge_e : t -> edge -> t - end + module G : Graph.Sig.G with type V.t = Sym.t val check_recursion_ok : (Sym.S.sym * Mucore.datatype) list -> G.V.t list list Typing.t end From ce60a32a245e7ca765cedf5dba54f3798b72b14c Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sat, 28 Dec 2024 12:25:12 +0000 Subject: [PATCH 134/148] CN: Simplify WellTyped interface This is in anticipation for a change from WellTyped depending on Typing to the other way around. --- backend/cn/lib/cLogicalFuns.ml | 10 +- backend/cn/lib/check.ml | 176 ++++++++++++++-------------- backend/cn/lib/diagnostics.ml | 4 +- backend/cn/lib/resourceInference.ml | 4 +- backend/cn/lib/wellTyped.ml | 52 ++++++++ backend/cn/lib/wellTyped.mli | 105 ++++++++--------- 6 files changed, 196 insertions(+), 155 deletions(-) diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index 3d269c197..d280d8749 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -186,7 +186,7 @@ let eval_fun f args orig_pexpr = match Mu.evaluate_fun f args with | Some (`Result_IT it) -> return it | Some (`Result_Integer z) -> - let@ () = WellTyped.ensure_bits_type loc bt in + let@ () = WellTyped.Exposed.ensure_bits_type loc bt in let bits_info = Option.get (BT.is_bits_bt bt) in if BT.fits_range bits_info z then return (IT.num_lit_ z bt loc) @@ -218,7 +218,7 @@ let eval_fun f args orig_pexpr = let rec symb_exec_pexpr ctxt var_map pexpr = let (Mu.Pexpr (loc, annots, _, pe)) = pexpr in let opt_bt = - WellTyped.BaseTyping.integer_annot annots + WellTyped.Exposed.integer_annot annots |> Option.map (fun ity -> Memory.bt_of_sct (Sctypes.Integer ity)) in Pp.debug @@ -412,7 +412,7 @@ let rec symb_exec_expr ctxt state_vars expr = let state, var_map = state_vars in let (Mu.Expr (loc, annots, _, e)) = expr in let opt_bt = - WellTyped.BaseTyping.integer_annot annots + WellTyped.Exposed.integer_annot annots |> Option.map (fun ity -> Memory.bt_of_sct (Sctypes.Integer ity)) in Pp.debug @@ -694,12 +694,12 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ } in let ctxt = { glob_context with label_defs = labels } in - let label_context = WellTyped.WProc.label_context rt labels in + let label_context = WellTyped.Exposed.label_context rt labels in let@ body = pure (in_computational_ctxt args_and_body - (WellTyped.BaseTyping.infer_expr label_context body)) + (WellTyped.Exposed.infer_expr label_context body)) in let@ r = symb_exec_expr ctxt (init_state, arg_map) body in let@ it = get_ret_it loc body def.Definition.Function.return_bt r in diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 14051f148..3dd1ac066 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -90,7 +90,7 @@ let check_ptrval (loc : Locations.t) ~(expect : BT.t) (ptrval : pointer_value) : ptrval (fun ct -> let sct = Sctypes.of_ctype_unsafe loc ct in - let@ () = WellTyped.WCT.is_ct loc sct in + let@ () = WellTyped.Exposed.check_ct loc sct in return (IT.null_ loc)) (function | None -> @@ -124,18 +124,18 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : CF.Impl_mem.case_mem_value mem (fun ct -> - let@ () = WellTyped.WCT.is_ct loc (Sctypes.of_ctype_unsafe loc ct) in + let@ () = WellTyped.Exposed.check_ct loc (Sctypes.of_ctype_unsafe loc ct) in fail (fun _ -> { loc; msg = Unspecified ct })) (fun _ _ -> unsupported loc !^"infer_mem_value: concurrent read case") (fun ity iv -> - let@ () = WellTyped.WCT.is_ct loc (Integer ity) in + let@ () = WellTyped.Exposed.check_ct loc (Integer ity) in let bt = Memory.bt_of_sct (Integer ity) in let@ () = ensure_base_type loc ~expect bt in return (int_lit_ (Memory.int_of_ival iv) bt loc)) (fun _ft _fv -> unsupported loc !^"floats") (fun ct ptrval -> (* TODO: do anything else with ct? *) - let@ () = WellTyped.WCT.is_ct loc (Sctypes.of_ctype_unsafe loc ct) in + let@ () = WellTyped.Exposed.check_ct loc (Sctypes.of_ctype_unsafe loc ct) in check_ptrval loc ~expect ptrval) (fun mem_values -> let@ index_bt, item_bt = expect_must_be_map_bt loc ~expect in @@ -143,7 +143,7 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : let@ values = ListM.mapM (check_mem_value loc ~expect:item_bt) mem_values in return (make_array_ ~index_bt ~item_bt values loc)) (fun tag mvals -> - let@ () = WellTyped.WCT.is_ct loc (Struct tag) in + let@ () = WellTyped.Exposed.check_ct loc (Struct tag) in let@ () = ensure_base_type loc ~expect (Struct tag) in let mvals = List.map (fun (id, ct, mv) -> (id, Sctypes.of_ctype_unsafe loc ct, mv)) mvals @@ -234,7 +234,7 @@ let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = | Vctype ct -> let@ () = ensure_base_type loc ~expect CType in let ct = Sctypes.of_ctype_unsafe loc ct in - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.Exposed.check_ct loc ct in return (IT.const_ctype_ ct loc) | Vunit -> let@ () = ensure_base_type loc ~expect Unit in @@ -325,7 +325,7 @@ let try_prove_constant loc expr = let check_single_ct loc expr = - let@ _pointer = WellTyped.WIT.check loc BT.CType expr in + let@ _pointer = WellTyped.Exposed.check_term loc BT.CType expr in let@ t = try_prove_constant loc expr in match IT.is_const t with | Some (IT.CType_const ct, _) -> return ct @@ -583,9 +583,9 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | Civfromfloat _ -> unsupported loc !^"floats" | PEarray_shift (pe1, ct, pe2) -> let@ () = ensure_base_type loc ~expect (Loc ()) in - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.Exposed.check_ct loc ct in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> (* NOTE: This case should not be present - only PtrArrayShift. The issue @@ -644,8 +644,8 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = (match op with | OpDiv -> let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.ensure_bits_type loc expect in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.Exposed.ensure_bits_type loc expect in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> let@ provable = provable loc in @@ -659,8 +659,8 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } }))) | OpRem_t -> let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.ensure_bits_type loc expect in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.Exposed.ensure_bits_type loc expect in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> let@ provable = provable loc in @@ -718,9 +718,9 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (or_ [ v1; v2 ] loc))) | OpAdd -> not_yet "OpAdd" | OpSub -> - let@ () = WellTyped.ensure_bits_type loc expect in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.Exposed.ensure_bits_type loc expect in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (sub_ (v1, v2) loc))) | OpMul -> not_yet "OpMul" | OpRem_f -> not_yet "OpRem_f" @@ -729,7 +729,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ () = match Mu.fun_return_type fun_id args with | Some (`Returns_BT bt) -> ensure_base_type loc ~expect bt - | Some `Returns_Integer -> WellTyped.ensure_bits_type loc expect + | Some `Returns_Integer -> WellTyped.Exposed.ensure_bits_type loc expect | None -> fail (fun _ -> { loc; @@ -757,7 +757,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ res = CLogicalFuns.eval_fun fun_id args orig_pe in k res) | PEstruct (tag, xs) -> - let@ () = WellTyped.WCT.is_ct loc (Struct tag) in + let@ () = WellTyped.Exposed.check_ct loc (Struct tag) in let@ () = ensure_base_type loc ~expect (Struct tag) in let@ layout = get_struct_decl loc tag in let member_types = Memory.member_types layout in @@ -796,15 +796,15 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | PEbounded_binop (Bound_Wrap act, iop, pe1, pe2) -> (* in integers, perform this op and round. in bitvector types, just perform the op (for all the ops where wrapping is consistent) *) - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in assert ( match act.ct with | Integer ity when Sctypes.is_unsigned_integer_type ity -> true | _ -> false); let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.ensure_bits_type loc expect in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.Exposed.ensure_bits_type loc expect in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in let@ () = match iop with | IOpShl | IOpShr -> return () @@ -841,12 +841,12 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in k x)) | PEbounded_binop (Bound_Except act, iop, pe1, pe2) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in let ity = match act.ct with Integer ity -> ity | _ -> assert false in let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.ensure_bits_type loc expect in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.Exposed.ensure_bits_type loc expect in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in let@ () = match iop with | IOpShl | IOpShr -> return () @@ -890,27 +890,27 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = k direct_x)) | PEconv_int (ct_expr, pe) | PEconv_loaded_int (ct_expr, pe) -> let@ () = ensure_base_type loc ~expect:CType (Mu.bt_of_pexpr ct_expr) in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr ct_expr (fun ct_it -> let@ ct = check_single_ct loc ct_it in - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.Exposed.check_ct loc ct in let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct ct) in check_pexpr pe (fun lvt -> let@ vt = check_conv_int loc ~expect ct lvt in k vt)) | PEwrapI (act, pe) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let bt = Memory.bt_of_sct act.ct in - let@ () = WellTyped.ensure_bits_type loc bt in + let@ () = WellTyped.Exposed.ensure_bits_type loc bt in k (cast_ bt arg loc)) | PEcatch_exceptional_condition (act, pe) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let bt = Memory.bt_of_sct act.ct in - let@ () = WellTyped.ensure_bits_type loc bt in + let@ () = WellTyped.Exposed.ensure_bits_type loc bt in let ity = Option.get (Sctypes.is_integer_type act.ct) in let@ provable = provable loc in match provable (LC.T (is_representable_integer arg ity)) with @@ -920,9 +920,9 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let ub = CF.Undefined.UB036_exceptional_condition in fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } })) | PEis_representable_integer (pe, act) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect Bool in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in let ity = Option.get (Sctypes.is_integer_type act.ct) in check_pexpr pe (fun arg -> k (is_representable_integer arg ity)) | PEif (pe, e1, e2) -> @@ -1077,7 +1077,7 @@ end = struct let check_arg_it (loc, it_arg) ~(expect : BT.t) k = - let@ it_arg = WellTyped.WIT.check loc expect it_arg in + let@ it_arg = WellTyped.Exposed.check_term loc expect it_arg in k it_arg @@ -1285,7 +1285,7 @@ let add_trace_information _labels annots = let bytes_qpred sym size pointer init : Req.QPredicate.t = let here = Locations.other __LOC__ in - let bt' = WellTyped.quantifier_bt in + let bt' = WellTyped.Exposed.default_quantifier_bt in { q = (sym, bt'); q_loc = here; step = IT.num_lit_ Z.one bt' here; @@ -1411,7 +1411,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrLe (pe1, pe2) -> pointer_op (Fun.flip lePointer_ loc) pe1 pe2 | PtrGe (pe1, pe2) -> pointer_op (Fun.flip gePointer_ loc) pe1 pe2 | Ptrdiff (act, pe1, pe2) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct (Integer Ptrdiff_t)) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in @@ -1440,8 +1440,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in k result)) | IntFromPtr (act_from, act_to, pe) -> - let@ () = WellTyped.WCT.is_ct act_from.loc act_from.ct in - let@ () = WellTyped.WCT.is_ct act_to.loc act_to.ct in + let@ () = WellTyped.Exposed.check_ct act_from.loc act_from.ct in + let@ () = WellTyped.Exposed.check_ct act_to.loc act_to.ct in assert (match act_to.ct with Integer _ -> true | _ -> false); let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act_to.ct) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in @@ -1467,8 +1467,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in k actual_value) | PtrFromInt (act_from, act_to, pe) -> - let@ () = WellTyped.WCT.is_ct act_from.loc act_from.ct in - let@ () = WellTyped.WCT.is_ct act_to.loc act_to.ct in + let@ () = WellTyped.Exposed.check_ct act_from.loc act_from.ct in + let@ () = WellTyped.Exposed.check_ct act_to.loc act_to.ct in let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = ensure_base_type @@ -1495,7 +1495,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k result) | PtrValidForDeref (act, pe) -> (* TODO (DCM, VIP) *) - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect Bool in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in (* TODO (DCM, VIP): error if called on Void or Function Ctype. @@ -1510,7 +1510,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let result = aligned_ (arg, act.ct) loc in k result) | PtrWellAligned (act, pe) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect Bool in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in (* TODO (DCM, VIP): error if called on Void or Function Ctype *) @@ -1522,8 +1522,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrArrayShift (pe1, act, pe2) -> let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> let result = @@ -1570,9 +1570,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Eaction (Paction (_pol, Action (_aloc, action_))) -> (match action_ with | Create (pe, act, prefix) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect (Loc ()) in - let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let ret_s, ret = match prefix with @@ -1621,7 +1621,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (* TODO (DCM, VIP) *) Cerb_debug.error "todo: Free" | Kill (Static ct, pe) -> - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.Exposed.check_ct loc ct in let@ () = ensure_base_type loc ~expect Unit in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> @@ -1637,7 +1637,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = record_action (Kill arg, loc) in k (unit_ loc)) | Store (_is_locking, act, p_pe, v_pe, _mo) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect Unit in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) in let@ () = @@ -1679,7 +1679,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = record_action (Write (parg, varg), loc) in k (unit_ loc))) | Load (act, p_pe, _mo) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) in check_pexpr p_pe (fun pointer -> @@ -1699,7 +1699,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = ensure_base_type loc ~expect Unit in k (unit_ loc) | Eccall (act, f_pe, pes) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.Exposed.check_ct act.loc act.ct in (* copied TS's, from wellTyped.ml *) (* let@ (_ret_ct, _arg_cts) = match act.ct with *) (* | Pointer (Function (ret_v_ct, arg_r_cts, is_variadic)) -> *) @@ -1796,7 +1796,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let rhs = let[@ocaml.warning "-8"] (b :: bytes) = List.init (Memory.size_of_integer_type it) (fun i -> - let index = int_lit_ i WellTyped.quantifier_bt here in + let index = int_lit_ i WellTyped.Exposed.default_quantifier_bt here in let casted = cast_ bt (map_get_ byte_arr index here) here in let shift_amt = int_lit_ (i * 8) bt here in IT.IT (Binop (ShiftLeft, casted, shift_amt), bt, here)) @@ -1806,7 +1806,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = eq_ (lhs, rhs) here | Pointer _ -> (* FIXME this totally ignores provenances *) - let bt = WellTyped.quantifier_bt in + let bt = WellTyped.Exposed.default_quantifier_bt in let lhs = cast_ bt value here in let rhs = let[@ocaml.warning "-8"] (b :: bytes) = @@ -1830,7 +1830,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | To_from_bytes ((To | From), { name = PName _; _ }) -> fail (fun _ -> { loc; msg = Byte_conv_needs_owned }) | To_from_bytes (To, { name = Owned (ct, init); pointer; _ }) -> - let@ pointer = WellTyped.WIT.infer pointer in + let@ pointer = WellTyped.Exposed.infer_term pointer in let@ (_, O value), _ = RI.Special.predicate_request loc @@ -1838,7 +1838,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (bytes_pred ct pointer init, None) in let q_sym = Sym.fresh_named "to_bytes" in - let bt = WellTyped.quantifier_bt in + let bt = WellTyped.Exposed.default_quantifier_bt in let map_bt = BT.Map (bt, Memory.bt_of_sct Sctypes.uchar_ct) in let byte_sym, byte_arr = IT.fresh_named map_bt "byte_arr" here in let@ () = add_a byte_sym map_bt (loc, lazy (Pp.string "byte array")) in @@ -1847,7 +1847,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Uninit -> add_c loc (LC.T (IT.eq_ (byte_arr, default_ map_bt here) here)) | Init -> add_c loc (LC.T (bytes_constraints ~value ~byte_arr ct))) | To_from_bytes (From, { name = Owned (ct, init); pointer; _ }) -> - let@ pointer = WellTyped.WIT.infer pointer in + let@ pointer = WellTyped.Exposed.infer_term pointer in let q_sym = Sym.fresh_named "from_bytes" in let@ (_, O byte_arr), _ = RI.Special.qpredicate_request @@ -1869,7 +1869,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Uninit -> add_c loc (LC.T (IT.eq_ (value, default_ value_bt here) here)) | Init -> add_c loc (LC.T (bytes_constraints ~value ~byte_arr ct))) | Have lc -> - let@ _lc = WellTyped.WLC.welltyped loc lc in + let@ _lc = WellTyped.Exposed.logical_constraint loc lc in fail (fun _ -> { loc; msg = Generic !^"todo: 'have' not implemented yet" }) | Instantiate (to_instantiate, it) -> let@ filter = @@ -1879,10 +1879,10 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ _ = get_logical_function_def loc f in return (IT.mentions_call f) | I_Good ct -> - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.Exposed.check_ct loc ct in return (IT.mentions_good ct) in - let@ it = WellTyped.WIT.infer it in + let@ it = WellTyped.Exposed.infer_term it in instantiate loc filter it | Split_case _ -> assert false | Extract (attrs, to_extract, it) -> @@ -1895,19 +1895,19 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let msg = "'extract' requires a C-type annotation for 'Owned'" in fail (fun _ -> { loc; msg = Generic !^msg }) | E_Pred (CN_owned (Some ct)) -> - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.Exposed.check_ct loc ct in return (Request.Owned (ct, Init)) | E_Pred (CN_block None) -> let msg = "'extract' requires a C-type annotation for 'Block'" in fail (fun _ -> { loc; msg = Generic !^msg }) | E_Pred (CN_block (Some ct)) -> - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.Exposed.check_ct loc ct in return (Request.Owned (ct, Uninit)) | E_Pred (CN_named pn) -> let@ _ = get_resource_predicate_def loc pn in return (Request.PName pn) in - let@ it = WellTyped.WIT.infer it in + let@ it = WellTyped.Exposed.infer_term it in let@ original_rs, _ = all_resources_tagged loc in (* let verbose = List.exists (Id.is_str "verbose") attrs in *) let quiet = List.exists (Id.equal_string "quiet") attrs in @@ -1925,7 +1925,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ def = get_logical_function_def loc f in let has_args, expect_args = (List.length args, List.length def.args) in let@ () = - WellTyped.ensure_same_argument_number + WellTyped.Exposed.ensure_same_argument_number loc `General has_args @@ -1933,7 +1933,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in let@ args = ListM.map2M - (fun has_arg (_, def_arg_bt) -> WellTyped.WIT.check loc def_arg_bt has_arg) + (fun has_arg (_, def_arg_bt) -> + WellTyped.Exposed.check_term loc def_arg_bt has_arg) args def.args in @@ -1958,7 +1959,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = bind_logical_return loc members lrt in return ()) | Assert lc -> - let@ lc = WellTyped.WLC.welltyped loc lc in + let@ lc = WellTyped.Exposed.logical_constraint loc lc in let@ provable = provable loc in (match provable lc with | `True -> return () @@ -1975,7 +1976,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = })) | Inline _nms -> return () | Print it -> - let@ it = WellTyped.WIT.infer it in + let@ it = WellTyped.Exposed.infer_term it in let@ simp_ctxt = simp_ctxt () in let it = Simplify.IndexTerms.simp simp_ctxt it in print stdout (item "printed" (IT.pp it)); @@ -1984,8 +1985,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let rec loop = function | [] -> k (unit_ loc) | Cnprog.Let (loc, (sym, { ct; pointer }), cn_prog) :: cn_progs -> - let@ pointer = WellTyped.WIT.check loc (Loc ()) pointer in - let@ () = WellTyped.WCT.is_ct loc ct in + let@ pointer = WellTyped.Exposed.check_term loc (Loc ()) pointer in + let@ () = WellTyped.Exposed.check_ct loc ct in let@ value = load loc pointer ct in let subbed = Cnprog.subst (IT.make_subst [ (sym, value) ]) cn_prog in loop (subbed :: cn_progs) @@ -1993,7 +1994,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (match cn_statement with | Cnprog.Split_case lc -> Pp.debug 5 (lazy (Pp.headline "checking split_case")); - let@ lc = WellTyped.WLC.welltyped loc lc in + let@ lc = WellTyped.Exposed.logical_constraint loc lc in let@ it = match lc with | T it -> return it @@ -2118,7 +2119,7 @@ let check_procedure pure (let@ () = modify_where (Where.set_function fsym) in let@ (body, label_defs, rt), initial_resources = bind_arguments loc args_and_body in - let label_context = WellTyped.WProc.label_context rt label_defs in + let label_context = WellTyped.Exposed.label_context rt label_defs in let label_defs = Pmap.bindings_list label_defs in let@ (), _mete_pre_state = debug 2 (lazy (headline ("checking function body " ^ Sym.pp_string fsym))); @@ -2189,7 +2190,7 @@ let check_tagdefs tagDefs = (* this should have been checked earlier by the frontend *) assert false | Some (name, ct) -> - let@ () = WellTyped.WCT.is_ct (Loc.other __LOC__) ct in + let@ () = WellTyped.Exposed.check_ct (Loc.other __LOC__) ct in return (IdSet.add name have) | None -> return have) layout @@ -2209,7 +2210,7 @@ let record_and_check_logical_functions funs = let@ () = ListM.iterM (fun (name, def) -> - let@ simple_def = WellTyped.WLFD.welltyped { def with body = Uninterp } in + let@ simple_def = WellTyped.Exposed.function_ { def with body = Uninterp } in add_logical_function name simple_def) recursive in @@ -2224,7 +2225,7 @@ let record_and_check_logical_functions funs = ^ Pp.of_total i n_funs ^ ": " ^ Sym.pp_string name))); - let@ def = WellTyped.WLFD.welltyped def in + let@ def = WellTyped.Exposed.function_ def in add_logical_function name def) funs @@ -2234,7 +2235,7 @@ let record_and_check_resource_predicates preds = let@ () = ListM.iterM (fun (name, def) -> - let@ simple_def = WellTyped.WRPD.welltyped { def with clauses = None } in + let@ simple_def = WellTyped.Exposed.predicate { def with clauses = None } in add_resource_predicate name simple_def) preds in @@ -2248,7 +2249,7 @@ let record_and_check_resource_predicates preds = ^ Pp.of_total i (List.length preds) ^ ": " ^ Sym.pp_string name))); - let@ def = WellTyped.WRPD.welltyped def in + let@ def = WellTyped.Exposed.predicate def in (* add simplified def to the context *) add_resource_predicate name def) preds @@ -2260,7 +2261,7 @@ let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> LC.t list m = (fun acc (sym, def) -> match def with | Mu.GlobalDef (ct, _) | GlobalDecl ct -> - let@ () = WellTyped.WCT.is_ct (Loc.other __LOC__) ct in + let@ () = WellTyped.Exposed.check_ct (Loc.other __LOC__) ct in let bt = BT.(Loc ()) in let info = (Loc.other __LOC__, lazy (Pp.item "global" (Sym.pp sym))) in let@ () = add_a sym bt info in @@ -2326,8 +2327,8 @@ let wf_check_and_record_functions funs call_sigs = match def with | Mu.Proc { loc; args_and_body; trusted = tr; _ } -> welltyped_ping i fsym; - let@ args_and_body = WellTyped.WProc.welltyped loc args_and_body in - let ft = WellTyped.WProc.typ args_and_body in + let@ args_and_body = WellTyped.Exposed.procedure loc args_and_body in + let ft = WellTyped.Exposed.to_argument_type args_and_body in debug 6 (lazy (!^"function type" ^^^ Sym.pp fsym)); debug 6 (lazy (CF.Pp_ast.pp_doc_tree (AT.dtree RT.dtree ft))); let@ () = add_fun_decl fsym (loc, Some ft, Pmap.find fsym call_sigs) in @@ -2340,7 +2341,7 @@ let wf_check_and_record_functions funs call_sigs = match oft with | None -> return None | Some ft -> - let@ ft = WellTyped.WFT.welltyped "function" loc ft in + let@ ft = WellTyped.Exposed.function_type "function" loc ft in return (Some ft) in let@ () = add_fun_decl fsym (loc, oft, Pmap.find fsym call_sigs) in @@ -2454,7 +2455,7 @@ let check_c_functions (funs : c_function list) : (string * TypeErrors.t) list m (* (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list *) let wf_check_and_record_lemma (lemma_s, (loc, lemma_typ)) = - let@ lemma_typ = WellTyped.WLemma.welltyped loc lemma_s lemma_typ in + let@ lemma_typ = WellTyped.Exposed.lemma loc lemma_s lemma_typ in let@ () = add_lemma lemma_s (loc, lemma_typ) in return (lemma_s, (loc, lemma_typ)) @@ -2511,7 +2512,7 @@ let memcpy_proxy_ft = let src_sym, src = IT.fresh_named (BT.Loc ()) "src" here in let n_sym, n = IT.fresh_named Memory.size_bt "n" here in (* requires *) - let q_bt = WellTyped.quantifier_bt in + let q_bt = WellTyped.Exposed.default_quantifier_bt in let uchar_bt = Memory.bt_of_sct Sctypes.uchar_ct in let map_bt = BT.Map (q_bt, uchar_bt) in let destIn_sym, _ = IT.fresh_named map_bt "destIn" here in @@ -2593,8 +2594,8 @@ let record_and_check_datatypes datatypes = datatypes in (* check and normalise datatypes *) - let@ datatypes = ListM.mapM WellTyped.WDT.welltyped datatypes in - let@ sccs = WellTyped.WDT.check_recursion_ok datatypes in + let@ datatypes = ListM.mapM WellTyped.Exposed.datatype datatypes in + let@ sccs = WellTyped.Exposed.datatype_recursion datatypes in let@ () = set_datatype_order (Some sccs) in (* properly add datatypes *) ListM.iterM @@ -2652,7 +2653,7 @@ let time_check_c_functions (global_var_constraints, (checked : c_function list)) Sym.Map.fold (fun _ def acc -> (* I think this avoids a left-recursion in the monad bind *) - let@ () = WellTyped.WRPD.consistent def in + let@ () = WellTyped.Exposed.predicate_consistent def in acc) global.resource_predicates (return ()) @@ -2664,14 +2665,15 @@ let time_check_c_functions (global_var_constraints, (checked : c_function list)) | None -> acc | Some def -> (* I think this avoids a left-recursion in the monad bind *) - let@ () = WellTyped.WFT.consistent "proc/fun" loc def in + let@ () = WellTyped.Exposed.function_type_consistent "proc/fun" loc def in acc) global.fun_decls (return ()) in let@ () = ListM.iterM - (fun (_, (loc, args_and_body)) -> WellTyped.WProc.consistent loc args_and_body) + (fun (_, (loc, args_and_body)) -> + WellTyped.Exposed.procedure_consistent loc args_and_body) checked in let@ errors = check_c_functions checked in @@ -2687,7 +2689,7 @@ let generate_lemmas lemmata o_lemma_mode = Sym.Map.fold (fun sym (loc, lemma_typ) acc -> (* I think this avoids a left-recursion in the monad bind *) - let@ () = WellTyped.WLemma.consistent loc sym lemma_typ in + let@ () = WellTyped.Exposed.lemma_consistent loc sym lemma_typ in acc) global.lemmata (return ()) diff --git a/backend/cn/lib/diagnostics.ml b/backend/cn/lib/diagnostics.ml index b22277552..9b143ee7e 100644 --- a/backend/cn/lib/diagnostics.ml +++ b/backend/cn/lib/diagnostics.ml @@ -103,8 +103,8 @@ let split_eq x y = | IT.Apply (nm, xs), IT.Apply (nm2, ys) when Sym.equal nm nm2 -> Some (List.map2 (fun x y -> (x, y)) xs ys) | IT.Constructor (nm, xs), IT.Constructor (nm2, ys) when Sym.equal nm nm2 -> - let xs = List.sort WellTyped.compare_by_fst_id xs in - let ys = List.sort WellTyped.compare_by_fst_id ys in + let xs = List.sort WellTyped.Exposed.compare_by_fst_id xs in + let ys = List.sort WellTyped.Exposed.compare_by_fst_id ys in Some (List.map2 (fun (_, x) (_, y) -> (x, y)) xs ys) | _ -> None diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index 285f1dfb6..d0e01a24d 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -160,7 +160,7 @@ module General = struct = Pp.(debug 7 (lazy (item __LOC__ (Req.pp (P requested))))); let start_timing = Pp.time_log_start __LOC__ "" in - let@ oarg_bt = WellTyped.WRS.oarg_bt_of_pred loc requested.name in + let@ oarg_bt = WellTyped.Exposed.oarg_bt_of_pred loc requested.name in let@ provable = provable loc in let@ global = get_global () in let@ simp_ctxt = simp_ctxt () in @@ -384,7 +384,7 @@ module General = struct and qpredicate_request loc uiinfo (requested : Req.QPredicate.t) = let@ o_oarg = qpredicate_request_aux loc uiinfo requested in - let@ oarg_item_bt = WellTyped.WRS.oarg_bt_of_pred loc requested.name in + let@ oarg_item_bt = WellTyped.Exposed.oarg_bt_of_pred loc requested.name in match o_oarg with | None -> return None | Some (oarg, rw_time) -> diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 9382cb3be..49baeaefe 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -2631,3 +2631,55 @@ module WDT = struct in return sccs end + +module Exposed = struct + let datatype = WDT.welltyped + + let datatype_recursion = WDT.check_recursion_ok + + let lemma_consistent = WLemma.consistent + + let lemma = WLemma.welltyped + + let function_ = WLFD.welltyped + + let predicate = WRPD.welltyped + + let predicate_consistent = WRPD.consistent + + let label_context = WProc.label_context + + let to_argument_type = WProc.typ + + let procedure_consistent = WProc.consistent + + let procedure = WProc.welltyped + + let integer_annot = BaseTyping.integer_annot + + let infer_expr = BaseTyping.infer_expr + + let check_expr = BaseTyping.check_expr + + let function_type = WFT.welltyped + + let function_type_consistent = WFT.consistent + + let logical_constraint = WLC.welltyped + + let oarg_bt_of_pred = WRS.oarg_bt_of_pred + + let default_quantifier_bt = quantifier_bt + + let infer_term = WIT.infer + + let check_term = WIT.check + + let check_ct = WCT.is_ct + + let compare_by_fst_id = compare_by_fst_id + + let ensure_same_argument_number = ensure_same_argument_number + + let ensure_bits_type = ensure_bits_type +end diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index 4f1e7e7c1..7aca7ac14 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -1,5 +1,3 @@ -module IdSet : Set.S with type elt = Id.t - module type NoSolver = sig type 'a m = 'a Typing.t @@ -47,108 +45,97 @@ end val use_ity : bool ref -val ensure_bits_type : Locations.t -> BaseTypes.t -> unit Typing.t +module Exposed : sig + val ensure_bits_type : Locations.t -> BaseTypes.t -> unit Typing.t -val ensure_same_argument_number - : Locations.t -> - [< `General | `Input | `Output ] -> - int -> - expect:int -> - unit Typing.t + val ensure_same_argument_number + : Locations.t -> + [< `General | `Input | `Output ] -> + int -> + expect:int -> + unit Typing.t -val compare_by_fst_id : Id.t * 'a -> Id.t * 'b -> int + val compare_by_fst_id : Id.t * 'a -> Id.t * 'b -> int -module WCT : (* keep *) sig - val is_ct : Locations.t -> Sctypes.ctype -> unit Typing.t -end + val check_ct : Locations.t -> Sctypes.ctype -> unit Typing.t -module WIT : sig - val infer : 'bt IndexTerms.annot -> IndexTerms.t Typing.t + val infer_term : 'bt IndexTerms.annot -> IndexTerms.t Typing.t - val check : Locations.t -> BaseTypes.t -> 'bt IndexTerms.annot -> IndexTerms.t Typing.t -end + val check_term + : Locations.t -> + BaseTypes.t -> + 'bt IndexTerms.annot -> + IndexTerms.t Typing.t -val quantifier_bt : 'a BaseTypes.t_gen + val default_quantifier_bt : BaseTypes.t -module WRS : sig val oarg_bt_of_pred : Locations.t -> Request.name -> BaseTypes.t Typing.t -end -module WLC : sig - val welltyped : Locations.t -> LogicalConstraints.t -> LogicalConstraints.t Typing.t -end + val logical_constraint + : Locations.t -> + LogicalConstraints.t -> + LogicalConstraints.t Typing.t -module WFT : sig - val consistent : string -> Locations.t -> ReturnTypes.t ArgumentTypes.t -> unit Typing.t + val function_type_consistent + : string -> + Locations.t -> + ReturnTypes.t ArgumentTypes.t -> + unit Typing.t - val welltyped + val function_type : string -> Locations.t -> ReturnTypes.t ArgumentTypes.t -> ReturnTypes.t ArgumentTypes.t Typing.t -end - -module BaseTyping : sig - type label_context = (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t val integer_annot : Cerb_frontend.Annot.annot list -> Cerb_frontend.IntegerType.integerType option - val infer_expr : label_context -> 'TY Mucore.expr -> BaseTypes.t Mucore.expr Typing.t + val infer_expr + : (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t -> + 'TY Mucore.expr -> + BaseTypes.t Mucore.expr Typing.t val check_expr - : label_context -> + : (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t -> BaseTypes.t -> 'TY Mucore.expr -> BaseTypes.t Mucore.expr Typing.t -end -module WProc : sig + val procedure + : Locations.t -> + 'TY1 Mucore.args_and_body -> + BaseTypes.t Mucore.args_and_body Typing.t + val label_context : ReturnTypes.t -> (Sym.Map.key, 'a Mucore.label_def) Pmap.map -> (False.t ArgumentTypes.t * Cerb_frontend.Annot.label_annot * Locations.t) Sym.Map.t - val typ : ('a * 'b * 'c) Mucore.arguments -> 'c ArgumentTypes.t - - val consistent : Locations.t -> 'TY1 Mucore.args_and_body -> unit Typing.t + val to_argument_type : ('a * 'b * 'c) Mucore.arguments -> 'c ArgumentTypes.t - val welltyped - : Locations.t -> - 'TY1 Mucore.args_and_body -> - BaseTypes.t Mucore.args_and_body Typing.t -end + val procedure_consistent : Locations.t -> 'TY1 Mucore.args_and_body -> unit Typing.t -module WRPD : sig - val consistent : Definition.Predicate.t -> unit Typing.m + val predicate_consistent : Definition.Predicate.t -> unit Typing.m - val welltyped : Definition.Predicate.t -> Definition.Predicate.t Typing.t -end + val predicate : Definition.Predicate.t -> Definition.Predicate.t Typing.t -module WLFD : sig - val welltyped : Definition.Function.t -> Definition.Function.t Typing.t -end + val function_ : Definition.Function.t -> Definition.Function.t Typing.t -module WLemma : (* keep *) - sig - val consistent + val lemma_consistent : Locations.t -> 'a -> LogicalReturnTypes.t ArgumentTypes.t -> unit Typing.t - val welltyped + val lemma : Locations.t -> 'a -> LogicalReturnTypes.t ArgumentTypes.t -> LogicalReturnTypes.t ArgumentTypes.t Typing.t -end - -module WDT : sig - val welltyped : 'a * Mucore.datatype -> ('a * Mucore.datatype) Typing.t - module G : Graph.Sig.G with type V.t = Sym.t + val datatype : 'a * Mucore.datatype -> ('a * Mucore.datatype) Typing.t - val check_recursion_ok : (Sym.S.sym * Mucore.datatype) list -> G.V.t list list Typing.t + val datatype_recursion : (Sym.t * Mucore.datatype) list -> Sym.t list list Typing.t end From 615098ed460bb42ee6ecb144f713e98eef62bcd3 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sat, 28 Dec 2024 21:20:21 +0000 Subject: [PATCH 135/148] CN: Adding missing elements for wellTyped interface --- backend/cn/lib/wellTyped.ml | 71 ++++++++++++++++++++---------------- backend/cn/lib/wellTyped.mli | 42 +++++++++++---------- 2 files changed, 63 insertions(+), 50 deletions(-) diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 49baeaefe..66416f4a3 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -11,56 +11,64 @@ let squotes, warn, dot, string, debug, item, colon, comma = module type NoSolver = sig (** TODO make this abstract, and one-way lifting functions? *) - type 'a m = 'a Typing.t + type 'a t = 'a Typing.t (* TODO: different error types for type errors, consistency errors, proof errors *) type failure = Context.t * Explain.log -> TypeErrors.t - val pure : 'a m -> 'a m + val return : 'a -> 'a t - val fail : failure -> 'a m + val bind : 'a t -> ('a -> 'b t) -> 'b t - val bound_a : Sym.t -> bool m + val pure : 'a t -> 'a t - val bound_l : Sym.t -> bool m + val fail : failure -> 'a t - val get_a : Sym.t -> Context.basetype_or_value m + val bound_a : Sym.t -> bool t - val get_l : Sym.t -> Context.basetype_or_value m + val bound_l : Sym.t -> bool t - val add_a : Sym.t -> BT.t -> Context.l_info -> unit m + val get_a : Sym.t -> Context.basetype_or_value t - val add_l : Sym.t -> BT.t -> Context.l_info -> unit m + val get_l : Sym.t -> Context.basetype_or_value t - val get_struct_decl : Loc.t -> Sym.t -> Memory.struct_layout m + val add_a : Sym.t -> BT.t -> Context.l_info -> unit t - val get_struct_member_type : Loc.t -> Sym.t -> Id.t -> Sctypes.ctype m + val add_l : Sym.t -> BT.t -> Context.l_info -> unit t - val get_datatype : Loc.t -> Sym.t -> BT.dt_info m + val get_struct_decl : Loc.t -> Sym.t -> Memory.struct_layout t - val get_datatype_constr : Loc.t -> Sym.t -> BT.constr_info m + val get_struct_member_type : Loc.t -> Sym.t -> Id.t -> Sctypes.ctype t - val get_resource_predicate_def : Loc.t -> Sym.t -> Definition.Predicate.t m + val get_datatype : Loc.t -> Sym.t -> BT.dt_info t - val get_logical_function_def : Loc.t -> Sym.t -> Definition.Function.t m + val get_datatype_constr : Loc.t -> Sym.t -> BT.constr_info t - val get_lemma : Loc.t -> Sym.t -> (Cerb_location.t * ArgumentTypes.lemmat) m + val get_resource_predicate_def : Loc.t -> Sym.t -> Definition.Predicate.t t + + val get_logical_function_def : Loc.t -> Sym.t -> Definition.Function.t t + + val get_lemma : Loc.t -> Sym.t -> (Cerb_location.t * ArgumentTypes.lemmat) t val get_fun_decl : Loc.t -> Sym.t -> - (Loc.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) m + (Loc.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) t - val ensure_base_type : Loc.t -> expect:BT.t -> BT.t -> unit m + val ensure_base_type : Loc.t -> expect:BT.t -> BT.t -> unit t - val lift : 'a Or_TypeError.t -> 'a m + val lift : 'a Or_TypeError.t -> 'a t end -open (Typing : NoSolver) +module Monad : NoSolver = Typing + +open Monad let fail typeErr = fail (fun _ -> typeErr) -open Effectful.Make (Typing) +module EffTyping = Effectful.Make (Typing) + +open Effectful.Make (Monad) let use_ity = ref true @@ -265,6 +273,8 @@ module WCT = struct fun ct -> aux ct end +type 'a m = 'a t + module WIT = struct open BaseTypes open IndexTerms @@ -1225,6 +1235,7 @@ module WRT = struct let pp = ReturnTypes.pp let consistent loc rt = + let open Typing in pure (match rt with | ReturnTypes.Computational ((name, bt), info, lrt) -> @@ -1265,7 +1276,7 @@ module WLAT = struct module LC = LogicalConstraints module LAT = LogicalArgumentTypes - let consistent i_welltyped i_pp kind loc (at : 'i LAT.t) : unit m = + let consistent i_welltyped i_pp kind loc (at : 'i LAT.t) : unit Typing.t = let open Typing in debug 12 @@ -1334,7 +1345,8 @@ end module WAT = struct module AT = ArgumentTypes - let consistent i_welltyped i_pp kind loc (at : 'i AT.t) : unit m = + let consistent i_welltyped i_pp kind loc (at : 'i AT.t) : unit Typing.t = + let open Typing in debug 12 (lazy @@ -1375,10 +1387,7 @@ module WFT = struct WRT.pp - let welltyped = - WAT.welltyped - (fun loc rt -> pure_and_no_initial_resources loc (WRT.welltyped loc rt)) - WRT.pp + let welltyped = WAT.welltyped (fun loc rt -> pure (WRT.welltyped loc rt)) WRT.pp end (* @@ -2372,7 +2381,7 @@ module WProc = struct fun (loc : Loc.t) (at : 'TY1 Mu.args_and_body) -> WArgs.welltyped (fun loc (body, labels, rt) -> - let@ rt = pure_and_no_initial_resources loc (WRT.welltyped loc rt) in + let@ rt = pure (WRT.welltyped loc rt) in let label_context = label_context rt labels in let@ labels = PmapM.mapM @@ -2381,8 +2390,7 @@ module WProc = struct | Return loc -> return (Return loc) | Label (loc, label_args_and_body, annots, parsed_spec, loop_info) -> let@ label_args_and_body = - pure_and_no_initial_resources - loc + pure (WArgs.welltyped (fun _loc label_body -> BaseTyping.check_expr label_context Unit label_body) @@ -2407,6 +2415,7 @@ module WRPD = struct let consistent Def.Predicate.{ loc; pointer; iargs; oarg_bt = _; clauses } = let open Typing in + let open EffTyping in (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure (let@ () = add_l pointer BT.(Loc ()) (loc, lazy (Pp.string "ptr-var")) in @@ -2520,7 +2529,7 @@ module WLemma = struct let welltyped loc _lemma_s lemma_typ = WAT.welltyped - (fun loc lrt -> pure_and_no_initial_resources loc (WLRT.welltyped loc lrt)) + (fun loc lrt -> pure (WLRT.welltyped loc lrt)) LogicalReturnTypes.pp "lemma" loc diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index 7aca7ac14..f55fb2bf1 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -1,46 +1,50 @@ module type NoSolver = sig - type 'a m = 'a Typing.t + type 'a t = 'a Typing.t type failure = Context.t * Explain.log -> TypeErrors.t - val pure : 'a m -> 'a m + val return : 'a -> 'a t - val fail : failure -> 'a m + val bind : 'a t -> ('a -> 'b t) -> 'b t - val bound_a : Sym.t -> bool m + val pure : 'a t -> 'a t - val bound_l : Sym.t -> bool m + val fail : failure -> 'a t - val get_a : Sym.t -> Context.basetype_or_value m + val bound_a : Sym.t -> bool t - val get_l : Sym.t -> Context.basetype_or_value m + val bound_l : Sym.t -> bool t - val add_a : Sym.t -> BaseTypes.t -> Context.l_info -> unit m + val get_a : Sym.t -> Context.basetype_or_value t - val add_l : Sym.t -> BaseTypes.t -> Context.l_info -> unit m + val get_l : Sym.t -> Context.basetype_or_value t - val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_layout m + val add_a : Sym.t -> BaseTypes.t -> Context.l_info -> unit t - val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.ctype m + val add_l : Sym.t -> BaseTypes.t -> Context.l_info -> unit t - val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info m + val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_layout t - val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info m + val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.ctype t - val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t m + val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info t - val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t m + val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info t - val get_lemma : Locations.t -> Sym.t -> (Locations.t * ArgumentTypes.lemmat) m + val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t t + + val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t t + + val get_lemma : Locations.t -> Sym.t -> (Locations.t * ArgumentTypes.lemmat) t val get_fun_decl : Locations.t -> Sym.t -> - (Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) m + (Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) t - val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit m + val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit t - val lift : 'a Or_TypeError.t -> 'a m + val lift : 'a Or_TypeError.t -> 'a t end val use_ity : bool ref From 5f9f5a49624ae0e32a3136d765eaf987245c049d Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sat, 28 Dec 2024 22:03:02 +0000 Subject: [PATCH 136/148] CN: Put consistency checks in separate file This is so that soon Typing can depend on WellTyped. --- backend/cn/lib/check.ml | 9 +- backend/cn/lib/consistent.ml | 245 +++++++++++++++++++++++++++++++++ backend/cn/lib/consistent.mli | 11 ++ backend/cn/lib/wellTyped.ml | 246 ---------------------------------- backend/cn/lib/wellTyped.mli | 16 --- 5 files changed, 260 insertions(+), 267 deletions(-) create mode 100644 backend/cn/lib/consistent.ml create mode 100644 backend/cn/lib/consistent.mli diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 3dd1ac066..373e5024f 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -2653,7 +2653,7 @@ let time_check_c_functions (global_var_constraints, (checked : c_function list)) Sym.Map.fold (fun _ def acc -> (* I think this avoids a left-recursion in the monad bind *) - let@ () = WellTyped.Exposed.predicate_consistent def in + let@ () = Consistent.predicate def in acc) global.resource_predicates (return ()) @@ -2665,15 +2665,14 @@ let time_check_c_functions (global_var_constraints, (checked : c_function list)) | None -> acc | Some def -> (* I think this avoids a left-recursion in the monad bind *) - let@ () = WellTyped.Exposed.function_type_consistent "proc/fun" loc def in + let@ () = Consistent.function_type "proc/fun" loc def in acc) global.fun_decls (return ()) in let@ () = ListM.iterM - (fun (_, (loc, args_and_body)) -> - WellTyped.Exposed.procedure_consistent loc args_and_body) + (fun (_, (loc, args_and_body)) -> Consistent.procedure loc args_and_body) checked in let@ errors = check_c_functions checked in @@ -2689,7 +2688,7 @@ let generate_lemmas lemmata o_lemma_mode = Sym.Map.fold (fun sym (loc, lemma_typ) acc -> (* I think this avoids a left-recursion in the monad bind *) - let@ () = WellTyped.Exposed.lemma_consistent loc sym lemma_typ in + let@ () = Consistent.lemma loc sym lemma_typ in acc) global.lemmata (return ()) diff --git a/backend/cn/lib/consistent.ml b/backend/cn/lib/consistent.ml new file mode 100644 index 000000000..78eb932f3 --- /dev/null +++ b/backend/cn/lib/consistent.ml @@ -0,0 +1,245 @@ +module LC = LogicalConstraints +module IT = IndexTerms +module Loc = Locations + +let debug, item = Pp.(debug, item) + +open Pp.Infix + +let pure, add_l, add_r, add_c, fail, provable, add_a, map_and_fold_resources = + Typing.(pure, add_l, add_r, add_c, fail, provable, add_a, map_and_fold_resources) + + +open Effectful.Make (Typing) + +let logicalReturnTypes loc lrt = + let rec aux = + let here = Locations.other __LOC__ in + function + | LogicalReturnTypes.Define ((s, it), ((loc, _) as info), lrt) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in + let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in + aux lrt + | Resource ((s, (re, re_oa_spec)), (loc, _), lrt) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in + let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in + aux lrt + | Constraint (lc, info, lrt) -> + (* TODO abort early if one of the constraints is the literal fase, + so that users are allowed to write such specs *) + let@ () = add_c (fst info) lc in + aux lrt + | I -> + let@ provable = provable loc in + let here = Locations.other __LOC__ in + (match provable (LC.T (IT.bool_ false here)) with + | `True -> + fail (fun ctxt_log -> + { loc; msg = Inconsistent_assumptions ("return type", ctxt_log) }) + | `False -> return ()) + in + pure (aux lrt) + + +let returnTypes loc rt = + pure + (match rt with + | ReturnTypes.Computational ((name, bt), info, lrt) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in + logicalReturnTypes loc lrt) + + +let logicalArgumentTypes i_welltyped i_pp kind loc at : unit Typing.t = + let module LAT = LogicalArgumentTypes in + let _ = (at : _ LAT.t) in + debug + 12 + (lazy (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (LAT.pp i_pp at))); + let rec aux = + let here = Locations.other __LOC__ in + function + | LAT.Define ((s, it), info, at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in + let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in + aux at + | Resource ((s, (re, re_oa_spec)), (loc, _), at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in + let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in + aux at + | Constraint (lc, info, at) -> + let@ () = add_c (fst info) lc in + aux at + | I i -> + let@ provable = provable loc in + let here = Locations.other __LOC__ in + let@ () = + match provable (LC.T (IT.bool_ false here)) with + | `True -> + fail (fun ctxt_log -> { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) + | `False -> return () + in + i_welltyped loc i + in + pure (aux at) + + +let argumentTypes i_welltyped i_pp kind loc at : unit Typing.t = + let module AT = ArgumentTypes in + let _ = (at : _ AT.t) in + debug + 12 + (lazy (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (AT.pp i_pp at))); + let rec aux = function + | AT.Computational ((name, bt), info, at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in + aux at + | L at -> logicalArgumentTypes i_welltyped i_pp kind loc at + in + pure (aux at) + + +let pure_and_no_initial_resources loc m = + pure + (let@ (), _ = map_and_fold_resources loc (fun _re () -> (Deleted, ())) () in + m) + + +let function_type = + argumentTypes + (fun loc rt -> pure_and_no_initial_resources loc (returnTypes loc rt)) + ReturnTypes.pp + + +let logicalArguments + (i_welltyped : Loc.t -> 'i -> 'j Typing.t) + kind + loc + (at : 'i Mucore.arguments_l) + : unit Typing.t + = + let rec aux = + let here = Locations.other __LOC__ in + function + | Mucore.Define ((s, it), ((loc, _) as info), at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in + let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in + aux at + | Resource ((s, (re, re_oa_spec)), (loc, _), at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in + let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in + aux at + | Constraint (lc, info, at) -> + let@ () = add_c (fst info) lc in + aux at + | I i -> + let@ provable = provable loc in + let here = Locations.other __LOC__ in + let@ () = + match provable (LC.T (IT.bool_ false here)) with + | `True -> + fail (fun ctxt_log -> { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) + | `False -> return () + in + i_welltyped loc i + in + pure (aux at) + + +let arguments + : (Loc.t -> 'i -> 'j Typing.t) -> string -> Loc.t -> 'i Mucore.arguments -> + unit Typing.t + = + fun (i_welltyped : Loc.t -> 'i -> 'j Typing.t) kind loc (at : 'i Mucore.arguments) -> + debug 6 (lazy !^__LOC__); + debug + 12 + (lazy + (item + ("checking consistency of " ^ kind ^ " at " ^ Loc.to_string loc) + (Cerb_frontend.Pp_ast.pp_doc_tree + (Mucore.dtree_of_arguments (fun _i -> Dleaf !^"...") at)))); + let rec aux = function + | Mucore.Computational ((name, bt), info, at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in + aux at + | L at -> logicalArguments i_welltyped kind loc at + in + pure (aux at) + + +let procedure : Loc.t -> _ Mucore.args_and_body -> unit Typing.t = + fun (loc : Loc.t) (at : 'TY1 Mucore.args_and_body) -> + arguments + (fun loc (_body, labels, rt) -> + let@ () = pure_and_no_initial_resources loc (returnTypes loc rt) in + PmapM.iterM + (fun _sym def -> + match def with + | Mucore.Return _ -> return () + | Label (loc, label_args_and_body, _annots, _parsed_spec, _loop_info) -> + pure_and_no_initial_resources + loc + (arguments + (fun _loc _label_body -> return ()) + "label" + loc + label_args_and_body)) + labels) + "function" + loc + at + + +let predicate pred = + let module Def = Definition in + let Def.Predicate.{ loc; pointer; iargs; oarg_bt = _; clauses } = pred in + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + pure + (let@ () = add_l pointer BaseTypes.(Loc ()) (loc, lazy (Pp.string "ptr-var")) in + let@ () = + ListM.iterM (fun (s, bt) -> add_l s bt (loc, lazy (Pp.string "input-var"))) iargs + in + match clauses with + | None -> return () + | Some clauses -> + let@ _ = + ListM.fold_leftM + (fun acc Def.Clause.{ loc; guard; packing_ft } -> + let here = Locations.other __LOC__ in + let negated_guards = + List.map (fun clause -> IT.not_ clause.Def.Clause.guard here) acc + in + pure + (let@ () = add_c loc (LC.T guard) in + let@ () = add_c loc (LC.T (IT.and_ negated_guards here)) in + let@ () = + logicalArgumentTypes + (fun _loc _it -> return ()) + IT.pp + "clause" + loc + packing_ft + in + return (acc @ [ Def.Clause.{ loc; guard; packing_ft } ]))) + [] + clauses + in + return ()) + + +let lemma loc _lemma_s lemma_typ = + argumentTypes + (fun loc lrt -> pure_and_no_initial_resources loc (logicalReturnTypes loc lrt)) + LogicalReturnTypes.pp + "lemma" + loc + lemma_typ diff --git a/backend/cn/lib/consistent.mli b/backend/cn/lib/consistent.mli new file mode 100644 index 000000000..d93cf1448 --- /dev/null +++ b/backend/cn/lib/consistent.mli @@ -0,0 +1,11 @@ +val function_type + : string -> + Locations.t -> + ReturnTypes.t ArgumentTypes.t -> + unit Typing.t + +val predicate : Definition.Predicate.t -> unit Typing.m + +val lemma : Locations.t -> 'a -> LogicalReturnTypes.t ArgumentTypes.t -> unit Typing.t + +val procedure : Locations.t -> 'TY1 Mucore.args_and_body -> unit Typing.t diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 66416f4a3..684e40a06 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -66,8 +66,6 @@ open Monad let fail typeErr = fail (fun _ -> typeErr) -module EffTyping = Effectful.Make (Typing) - open Effectful.Make (Monad) let use_ity = ref true @@ -1173,41 +1171,8 @@ module WLC = struct end module WLRT = struct - module LC = LogicalConstraints module LRT = LogicalReturnTypes - let consistent loc lrt = - let open Typing in - let rec aux = - let here = Locations.other __LOC__ in - function - | LRT.Define ((s, it), ((loc, _) as info), lrt) -> - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in - aux lrt - | Resource ((s, (re, re_oa_spec)), (loc, _), lrt) -> - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in - let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in - aux lrt - | Constraint (lc, info, lrt) -> - (* TODO abort early if one of the constraints is the literal fase, - so that users are allowed to write such specs *) - let@ () = add_c (fst info) lc in - aux lrt - | I -> - let@ provable = provable loc in - let here = Locations.other __LOC__ in - (match provable (LC.T (IT.bool_ false here)) with - | `True -> - fail (fun ctxt_log -> - { loc; msg = Inconsistent_assumptions ("return type", ctxt_log) }) - | `False -> return ()) - in - pure (aux lrt) - - let welltyped _loc lrt = let rec aux = function | LRT.Define ((s, it), ((loc, _) as info), lrt) -> @@ -1234,16 +1199,6 @@ end module WRT = struct let pp = ReturnTypes.pp - let consistent loc rt = - let open Typing in - pure - (match rt with - | ReturnTypes.Computational ((name, bt), info, lrt) -> - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in - WLRT.consistent loc lrt) - - let welltyped loc rt = pure (match rt with @@ -1265,54 +1220,9 @@ end (* let welltyped _ False.False = return False.False *) (* end *) -let pure_and_no_initial_resources loc m = - let open Typing in - pure - (let@ (), _ = map_and_fold_resources loc (fun _re () -> (Deleted, ())) () in - m) - - module WLAT = struct - module LC = LogicalConstraints module LAT = LogicalArgumentTypes - let consistent i_welltyped i_pp kind loc (at : 'i LAT.t) : unit Typing.t = - let open Typing in - debug - 12 - (lazy - (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (LAT.pp i_pp at))); - let rec aux = - let here = Locations.other __LOC__ in - function - | LAT.Define ((s, it), info, at) -> - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in - aux at - | LAT.Resource ((s, (re, re_oa_spec)), (loc, _), at) -> - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in - let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in - aux at - | LAT.Constraint (lc, info, at) -> - let@ () = add_c (fst info) lc in - aux at - | LAT.I i -> - let@ provable = provable loc in - let here = Locations.other __LOC__ in - let@ () = - match provable (LC.T (IT.bool_ false here)) with - | `True -> - fail (fun ctxt_log -> - { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) - | `False -> return () - in - i_welltyped loc i - in - pure (aux at) - - let welltyped i_welltyped i_pp kind loc (at : 'i LAT.t) : 'i LAT.t m = debug 12 @@ -1345,22 +1255,6 @@ end module WAT = struct module AT = ArgumentTypes - let consistent i_welltyped i_pp kind loc (at : 'i AT.t) : unit Typing.t = - let open Typing in - debug - 12 - (lazy - (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (AT.pp i_pp at))); - let rec aux = function - | AT.Computational ((name, bt), info, at) -> - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in - aux at - | AT.L at -> WLAT.consistent i_welltyped i_pp kind loc at - in - pure (aux at) - - let welltyped i_welltyped i_pp kind loc (at : 'i AT.t) : 'i AT.t m = debug 12 @@ -1381,12 +1275,6 @@ module WAT = struct end module WFT = struct - let consistent = - WAT.consistent - (fun loc rt -> pure_and_no_initial_resources loc (WRT.consistent loc rt)) - WRT.pp - - let welltyped = WAT.welltyped (fun loc rt -> pure (WRT.welltyped loc rt)) WRT.pp end @@ -1402,7 +1290,6 @@ end (pd.oargs)) *) module WLArgs = struct - module LC = LogicalConstraints module LAT = LogicalArgumentTypes module Mu = Mucore @@ -1413,41 +1300,6 @@ module WLArgs = struct | Mu.I i -> LAT.I (ityp i) - let consistent (i_welltyped : Loc.t -> 'i -> 'j m) kind loc (at : 'i Mu.arguments_l) - : unit m - = - let open Typing in - let rec aux = - let here = Locations.other __LOC__ in - function - | Mu.Define ((s, it), ((loc, _) as info), at) -> - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in - aux at - | Mu.Resource ((s, (re, re_oa_spec)), (loc, _), at) -> - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in - let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in - aux at - | Mu.Constraint (lc, info, at) -> - let@ () = add_c (fst info) lc in - aux at - | Mu.I i -> - let@ provable = provable loc in - let here = Locations.other __LOC__ in - let@ () = - match provable (LC.T (IT.bool_ false here)) with - | `True -> - fail (fun ctxt_log -> - { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) - | `False -> return () - in - i_welltyped loc i - in - pure (aux at) - - let welltyped (i_welltyped : Loc.t -> 'i -> 'j m) _kind loc (at : 'i Mu.arguments_l) : 'j Mu.arguments_l m = @@ -1484,26 +1336,6 @@ module WArgs = struct | Mu.L lat -> AT.L (WLArgs.typ ityp lat) - let consistent : (Loc.t -> 'i -> 'j m) -> string -> Loc.t -> 'i Mu.arguments -> unit m = - fun (i_welltyped : Loc.t -> 'i -> 'j m) kind loc (at : 'i Mu.arguments) -> - debug 6 (lazy !^__LOC__); - debug - 12 - (lazy - (item - ("checking consistency of " ^ kind ^ " at " ^ Loc.to_string loc) - (CF.Pp_ast.pp_doc_tree - (Mucore.dtree_of_arguments (fun _i -> Dleaf !^"...") at)))); - let rec aux = function - | Mu.Computational ((name, bt), info, at) -> - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in - aux at - | Mu.L at -> WLArgs.consistent i_welltyped kind loc at - in - pure (aux at) - - let welltyped : 'i 'j. (Loc.t -> 'i -> 'j m) -> string -> Loc.t -> 'i Mu.arguments -> 'j Mu.arguments m @@ -2354,29 +2186,6 @@ module WProc = struct let typ p = WArgs.typ (fun (_body, _labels, rt) -> rt) p - let consistent : Loc.t -> _ Mu.args_and_body -> unit m = - fun (loc : Loc.t) (at : 'TY1 Mu.args_and_body) -> - WArgs.consistent - (fun loc (_body, labels, rt) -> - let@ () = pure_and_no_initial_resources loc (WRT.consistent loc rt) in - PmapM.iterM - (fun _sym def -> - match def with - | Return _ -> return () - | Label (loc, label_args_and_body, _annots, _parsed_spec, _loop_info) -> - pure_and_no_initial_resources - loc - (WArgs.consistent - (fun _loc _label_body -> return ()) - "label" - loc - label_args_and_body)) - labels) - "function" - loc - at - - let welltyped : Loc.t -> _ Mu.args_and_body -> _ Mu.args_and_body m = fun (loc : Loc.t) (at : 'TY1 Mu.args_and_body) -> WArgs.welltyped @@ -2411,44 +2220,6 @@ end module WRPD = struct module Def = Definition - module LC = LogicalConstraints - - let consistent Def.Predicate.{ loc; pointer; iargs; oarg_bt = _; clauses } = - let open Typing in - let open EffTyping in - (* no need to alpha-rename, because context.ml ensures there's no name clashes *) - pure - (let@ () = add_l pointer BT.(Loc ()) (loc, lazy (Pp.string "ptr-var")) in - let@ () = - ListM.iterM (fun (s, bt) -> add_l s bt (loc, lazy (Pp.string "input-var"))) iargs - in - match clauses with - | None -> return () - | Some clauses -> - let@ _ = - ListM.fold_leftM - (fun acc Def.Clause.{ loc; guard; packing_ft } -> - let here = Locations.other __LOC__ in - let negated_guards = - List.map (fun clause -> IT.not_ clause.Def.Clause.guard here) acc - in - pure - (let@ () = add_c loc (LC.T guard) in - let@ () = add_c loc (LC.T (IT.and_ negated_guards here)) in - let@ () = - WLAT.consistent - (fun _loc _it -> return ()) - IT.pp - "clause" - loc - packing_ft - in - return (acc @ [ Def.Clause.{ loc; guard; packing_ft } ]))) - [] - clauses - in - return ()) - let welltyped Def.Predicate.{ loc; pointer; iargs; oarg_bt; clauses } = (* no need to alpha-rename, because context.ml ensures there's no name clashes *) @@ -2518,15 +2289,6 @@ module WLFD = struct end module WLemma = struct - let consistent loc _lemma_s lemma_typ = - WAT.consistent - (fun loc lrt -> pure_and_no_initial_resources loc (WLRT.consistent loc lrt)) - LogicalReturnTypes.pp - "lemma" - loc - lemma_typ - - let welltyped loc _lemma_s lemma_typ = WAT.welltyped (fun loc lrt -> pure (WLRT.welltyped loc lrt)) @@ -2646,22 +2408,16 @@ module Exposed = struct let datatype_recursion = WDT.check_recursion_ok - let lemma_consistent = WLemma.consistent - let lemma = WLemma.welltyped let function_ = WLFD.welltyped let predicate = WRPD.welltyped - let predicate_consistent = WRPD.consistent - let label_context = WProc.label_context let to_argument_type = WProc.typ - let procedure_consistent = WProc.consistent - let procedure = WProc.welltyped let integer_annot = BaseTyping.integer_annot @@ -2672,8 +2428,6 @@ module Exposed = struct let function_type = WFT.welltyped - let function_type_consistent = WFT.consistent - let logical_constraint = WLC.welltyped let oarg_bt_of_pred = WRS.oarg_bt_of_pred diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index f55fb2bf1..46c54a91a 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -80,12 +80,6 @@ module Exposed : sig LogicalConstraints.t -> LogicalConstraints.t Typing.t - val function_type_consistent - : string -> - Locations.t -> - ReturnTypes.t ArgumentTypes.t -> - unit Typing.t - val function_type : string -> Locations.t -> @@ -119,20 +113,10 @@ module Exposed : sig val to_argument_type : ('a * 'b * 'c) Mucore.arguments -> 'c ArgumentTypes.t - val procedure_consistent : Locations.t -> 'TY1 Mucore.args_and_body -> unit Typing.t - - val predicate_consistent : Definition.Predicate.t -> unit Typing.m - val predicate : Definition.Predicate.t -> Definition.Predicate.t Typing.t val function_ : Definition.Function.t -> Definition.Function.t Typing.t - val lemma_consistent - : Locations.t -> - 'a -> - LogicalReturnTypes.t ArgumentTypes.t -> - unit Typing.t - val lemma : Locations.t -> 'a -> From 8c64501c3e3a5a9ebe39e3b50ede66cdc2af2d3e Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sun, 29 Dec 2024 00:46:42 +0000 Subject: [PATCH 137/148] CN: Make Typing depend on WellTyped Achieved this by functorising WellTyped and hoisting out the signatures to a separate file. Types are all still exposed though. --- backend/cn/lib/sigs.ml | 122 +++++++++++++++++++++++++++++++++ backend/cn/lib/typing.ml | 57 ++++++++++++++++ backend/cn/lib/typing.mli | 6 ++ backend/cn/lib/wellTyped.ml | 57 +--------------- backend/cn/lib/wellTyped.mli | 128 +---------------------------------- 5 files changed, 190 insertions(+), 180 deletions(-) create mode 100644 backend/cn/lib/sigs.ml diff --git a/backend/cn/lib/sigs.ml b/backend/cn/lib/sigs.ml new file mode 100644 index 000000000..5e85c975c --- /dev/null +++ b/backend/cn/lib/sigs.ml @@ -0,0 +1,122 @@ +module type NoSolver = sig + type 'a t + + type failure = Context.t * Explain.log -> TypeErrors.t + + val return : 'a -> 'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + val pure : 'a t -> 'a t + + val fail : failure -> 'a t + + val bound_a : Sym.t -> bool t + + val bound_l : Sym.t -> bool t + + val get_a : Sym.t -> Context.basetype_or_value t + + val get_l : Sym.t -> Context.basetype_or_value t + + val add_a : Sym.t -> BaseTypes.t -> Context.l_info -> unit t + + val add_l : Sym.t -> BaseTypes.t -> Context.l_info -> unit t + + val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_layout t + + val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.ctype t + + val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info t + + val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info t + + val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t t + + val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t t + + val get_lemma : Locations.t -> Sym.t -> (Locations.t * ArgumentTypes.lemmat) t + + val get_fun_decl + : Locations.t -> + Sym.t -> + (Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) t + + val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit t + + val lift : 'a Or_TypeError.t -> 'a t +end + +module type Exposed = sig + type 'a t + + val ensure_bits_type : Locations.t -> BaseTypes.t -> unit t + + val ensure_same_argument_number + : Locations.t -> + [< `General | `Input | `Output ] -> + int -> + expect:int -> + unit t + + val compare_by_fst_id : Id.t * 'a -> Id.t * 'b -> int + + val check_ct : Locations.t -> Sctypes.ctype -> unit t + + val infer_term : 'bt IndexTerms.annot -> IndexTerms.t t + + val check_term : Locations.t -> BaseTypes.t -> 'bt IndexTerms.annot -> IndexTerms.t t + + val default_quantifier_bt : BaseTypes.t + + val oarg_bt_of_pred : Locations.t -> Request.name -> BaseTypes.t t + + val logical_constraint : Locations.t -> LogicalConstraints.t -> LogicalConstraints.t t + + val function_type + : string -> + Locations.t -> + ReturnTypes.t ArgumentTypes.t -> + ReturnTypes.t ArgumentTypes.t t + + val integer_annot + : Cerb_frontend.Annot.annot list -> + Cerb_frontend.IntegerType.integerType option + + val infer_expr + : (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t -> + 'TY Mucore.expr -> + BaseTypes.t Mucore.expr t + + val check_expr + : (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t -> + BaseTypes.t -> + 'TY Mucore.expr -> + BaseTypes.t Mucore.expr t + + val procedure + : Locations.t -> + 'TY1 Mucore.args_and_body -> + BaseTypes.t Mucore.args_and_body t + + val label_context + : ReturnTypes.t -> + (Sym.Map.key, 'a Mucore.label_def) Pmap.map -> + (False.t ArgumentTypes.t * Cerb_frontend.Annot.label_annot * Locations.t) Sym.Map.t + + val to_argument_type : ('a * 'b * 'c) Mucore.arguments -> 'c ArgumentTypes.t + + val predicate : Definition.Predicate.t -> Definition.Predicate.t t + + val function_ : Definition.Function.t -> Definition.Function.t t + + val lemma + : Locations.t -> + 'a -> + LogicalReturnTypes.t ArgumentTypes.t -> + LogicalReturnTypes.t ArgumentTypes.t t + + val datatype : 'a * Mucore.datatype -> ('a * Mucore.datatype) t + + val datatype_recursion : (Sym.t * Mucore.datatype) list -> Sym.t list list t +end diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 72d392b29..d2dea29e5 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -823,3 +823,60 @@ let test_value_eqs loc guard x ys = let@ group = value_eq_group guard x in let@ ms = prev_models_with loc guard_it in loop group ms ys + + +module NoSolver = struct + type nonrec 'a t = 'a t + + type nonrec failure = failure + + let return = return + + let bind = bind + + let pure = pure + + let fail = fail + + let bound_a = bound_a + + let bound_l = bound_l + + let get_a = get_a + + let get_l = get_l + + let add_a = add_a + + let add_l = add_l + + let get_struct_decl = get_struct_decl + + let get_struct_member_type = get_struct_member_type + + let get_datatype = get_datatype + + let get_datatype_constr = get_datatype_constr + + let get_resource_predicate_def = get_resource_predicate_def + + let get_logical_function_def = get_logical_function_def + + let get_lemma = get_lemma + + let get_fun_decl = get_fun_decl + + let ensure_base_type = ensure_base_type + + let lift = function Ok x -> return x | Error x -> fail (fun _ -> x) +end + +module Made = WellTyped.Make (NoSolver) + +module WellTyped = struct + module Exposed = struct + type nonrec 'a t = 'a t + + include Made.Exposed + end +end diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 2c0b95fda..c84f3e0e5 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -180,3 +180,9 @@ val modify_where : (Where.t -> Where.t) -> unit m (* val add_trace_item_to_trace : Context.trace_item * Locations.t -> unit m *) val init_solver : unit -> unit m + +module NoSolver : Sigs.NoSolver with type 'a t = 'a t + +module WellTyped : sig + module Exposed : Sigs.Exposed with type 'a t = 'a t +end diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 684e40a06..084612f50 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -9,67 +9,15 @@ let squotes, warn, dot, string, debug, item, colon, comma = Pp.(squotes, warn, dot, string, debug, item, colon, comma) -module type NoSolver = sig - (** TODO make this abstract, and one-way lifting functions? *) - type 'a t = 'a Typing.t - - (* TODO: different error types for type errors, consistency errors, proof errors *) - type failure = Context.t * Explain.log -> TypeErrors.t - - val return : 'a -> 'a t - - val bind : 'a t -> ('a -> 'b t) -> 'b t - - val pure : 'a t -> 'a t - - val fail : failure -> 'a t - - val bound_a : Sym.t -> bool t - - val bound_l : Sym.t -> bool t - - val get_a : Sym.t -> Context.basetype_or_value t - - val get_l : Sym.t -> Context.basetype_or_value t - - val add_a : Sym.t -> BT.t -> Context.l_info -> unit t - - val add_l : Sym.t -> BT.t -> Context.l_info -> unit t - - val get_struct_decl : Loc.t -> Sym.t -> Memory.struct_layout t - - val get_struct_member_type : Loc.t -> Sym.t -> Id.t -> Sctypes.ctype t - - val get_datatype : Loc.t -> Sym.t -> BT.dt_info t - - val get_datatype_constr : Loc.t -> Sym.t -> BT.constr_info t - - val get_resource_predicate_def : Loc.t -> Sym.t -> Definition.Predicate.t t - - val get_logical_function_def : Loc.t -> Sym.t -> Definition.Function.t t - - val get_lemma : Loc.t -> Sym.t -> (Cerb_location.t * ArgumentTypes.lemmat) t - - val get_fun_decl - : Loc.t -> - Sym.t -> - (Loc.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) t - - val ensure_base_type : Loc.t -> expect:BT.t -> BT.t -> unit t - - val lift : 'a Or_TypeError.t -> 'a t -end - -module Monad : NoSolver = Typing +let use_ity = ref true +module Make (Monad : Sigs.NoSolver) = struct open Monad let fail typeErr = fail (fun _ -> typeErr) open Effectful.Make (Monad) -let use_ity = ref true - let illtyped_index_term (loc : Locations.t) it has ~expected ~reason = let reason = match reason with @@ -2446,3 +2394,4 @@ module Exposed = struct let ensure_bits_type = ensure_bits_type end +end[@@ocamlformat "disable"] diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index 46c54a91a..38d28f3d2 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -1,129 +1,5 @@ -module type NoSolver = sig - type 'a t = 'a Typing.t - - type failure = Context.t * Explain.log -> TypeErrors.t - - val return : 'a -> 'a t - - val bind : 'a t -> ('a -> 'b t) -> 'b t - - val pure : 'a t -> 'a t - - val fail : failure -> 'a t - - val bound_a : Sym.t -> bool t - - val bound_l : Sym.t -> bool t - - val get_a : Sym.t -> Context.basetype_or_value t - - val get_l : Sym.t -> Context.basetype_or_value t - - val add_a : Sym.t -> BaseTypes.t -> Context.l_info -> unit t - - val add_l : Sym.t -> BaseTypes.t -> Context.l_info -> unit t - - val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_layout t - - val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.ctype t - - val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info t - - val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info t - - val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t t - - val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t t - - val get_lemma : Locations.t -> Sym.t -> (Locations.t * ArgumentTypes.lemmat) t - - val get_fun_decl - : Locations.t -> - Sym.t -> - (Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) t - - val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit t - - val lift : 'a Or_TypeError.t -> 'a t -end - val use_ity : bool ref -module Exposed : sig - val ensure_bits_type : Locations.t -> BaseTypes.t -> unit Typing.t - - val ensure_same_argument_number - : Locations.t -> - [< `General | `Input | `Output ] -> - int -> - expect:int -> - unit Typing.t - - val compare_by_fst_id : Id.t * 'a -> Id.t * 'b -> int - - val check_ct : Locations.t -> Sctypes.ctype -> unit Typing.t - - val infer_term : 'bt IndexTerms.annot -> IndexTerms.t Typing.t - - val check_term - : Locations.t -> - BaseTypes.t -> - 'bt IndexTerms.annot -> - IndexTerms.t Typing.t - - val default_quantifier_bt : BaseTypes.t - - val oarg_bt_of_pred : Locations.t -> Request.name -> BaseTypes.t Typing.t - - val logical_constraint - : Locations.t -> - LogicalConstraints.t -> - LogicalConstraints.t Typing.t - - val function_type - : string -> - Locations.t -> - ReturnTypes.t ArgumentTypes.t -> - ReturnTypes.t ArgumentTypes.t Typing.t - - val integer_annot - : Cerb_frontend.Annot.annot list -> - Cerb_frontend.IntegerType.integerType option - - val infer_expr - : (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t -> - 'TY Mucore.expr -> - BaseTypes.t Mucore.expr Typing.t - - val check_expr - : (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t -> - BaseTypes.t -> - 'TY Mucore.expr -> - BaseTypes.t Mucore.expr Typing.t - - val procedure - : Locations.t -> - 'TY1 Mucore.args_and_body -> - BaseTypes.t Mucore.args_and_body Typing.t - - val label_context - : ReturnTypes.t -> - (Sym.Map.key, 'a Mucore.label_def) Pmap.map -> - (False.t ArgumentTypes.t * Cerb_frontend.Annot.label_annot * Locations.t) Sym.Map.t - - val to_argument_type : ('a * 'b * 'c) Mucore.arguments -> 'c ArgumentTypes.t - - val predicate : Definition.Predicate.t -> Definition.Predicate.t Typing.t - - val function_ : Definition.Function.t -> Definition.Function.t Typing.t - - val lemma - : Locations.t -> - 'a -> - LogicalReturnTypes.t ArgumentTypes.t -> - LogicalReturnTypes.t ArgumentTypes.t Typing.t - - val datatype : 'a * Mucore.datatype -> ('a * Mucore.datatype) Typing.t - - val datatype_recursion : (Sym.t * Mucore.datatype) list -> Sym.t list list Typing.t +module Make : functor (Monad : Sigs.NoSolver) -> sig + module Exposed : Sigs.Exposed with type 'a t := 'a Monad.t end From 288876179a4145a328f1a32bec267fc393821e4f Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sun, 29 Dec 2024 01:09:44 +0000 Subject: [PATCH 138/148] CN: Remove use of WellTyped.Exposed --- backend/cn/lib/cLogicalFuns.ml | 13 +-- backend/cn/lib/check.ml | 166 ++++++++++++++-------------- backend/cn/lib/diagnostics.ml | 4 +- backend/cn/lib/resourceInference.ml | 4 +- backend/cn/lib/typing.ml | 10 +- backend/cn/lib/typing.mli | 6 +- 6 files changed, 96 insertions(+), 107 deletions(-) diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index d280d8749..ca243d21e 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -186,7 +186,7 @@ let eval_fun f args orig_pexpr = match Mu.evaluate_fun f args with | Some (`Result_IT it) -> return it | Some (`Result_Integer z) -> - let@ () = WellTyped.Exposed.ensure_bits_type loc bt in + let@ () = WellTyped.ensure_bits_type loc bt in let bits_info = Option.get (BT.is_bits_bt bt) in if BT.fits_range bits_info z then return (IT.num_lit_ z bt loc) @@ -218,7 +218,7 @@ let eval_fun f args orig_pexpr = let rec symb_exec_pexpr ctxt var_map pexpr = let (Mu.Pexpr (loc, annots, _, pe)) = pexpr in let opt_bt = - WellTyped.Exposed.integer_annot annots + WellTyped.integer_annot annots |> Option.map (fun ity -> Memory.bt_of_sct (Sctypes.Integer ity)) in Pp.debug @@ -412,7 +412,7 @@ let rec symb_exec_expr ctxt state_vars expr = let state, var_map = state_vars in let (Mu.Expr (loc, annots, _, e)) = expr in let opt_bt = - WellTyped.Exposed.integer_annot annots + WellTyped.integer_annot annots |> Option.map (fun ity -> Memory.bt_of_sct (Sctypes.Integer ity)) in Pp.debug @@ -694,12 +694,9 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ } in let ctxt = { glob_context with label_defs = labels } in - let label_context = WellTyped.Exposed.label_context rt labels in + let label_context = WellTyped.label_context rt labels in let@ body = - pure - (in_computational_ctxt - args_and_body - (WellTyped.Exposed.infer_expr label_context body)) + pure (in_computational_ctxt args_and_body (WellTyped.infer_expr label_context body)) in let@ r = symb_exec_expr ctxt (init_state, arg_map) body in let@ it = get_ret_it loc body def.Definition.Function.return_bt r in diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 373e5024f..5dbb54d2a 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -90,7 +90,7 @@ let check_ptrval (loc : Locations.t) ~(expect : BT.t) (ptrval : pointer_value) : ptrval (fun ct -> let sct = Sctypes.of_ctype_unsafe loc ct in - let@ () = WellTyped.Exposed.check_ct loc sct in + let@ () = WellTyped.check_ct loc sct in return (IT.null_ loc)) (function | None -> @@ -124,18 +124,18 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : CF.Impl_mem.case_mem_value mem (fun ct -> - let@ () = WellTyped.Exposed.check_ct loc (Sctypes.of_ctype_unsafe loc ct) in + let@ () = WellTyped.check_ct loc (Sctypes.of_ctype_unsafe loc ct) in fail (fun _ -> { loc; msg = Unspecified ct })) (fun _ _ -> unsupported loc !^"infer_mem_value: concurrent read case") (fun ity iv -> - let@ () = WellTyped.Exposed.check_ct loc (Integer ity) in + let@ () = WellTyped.check_ct loc (Integer ity) in let bt = Memory.bt_of_sct (Integer ity) in let@ () = ensure_base_type loc ~expect bt in return (int_lit_ (Memory.int_of_ival iv) bt loc)) (fun _ft _fv -> unsupported loc !^"floats") (fun ct ptrval -> (* TODO: do anything else with ct? *) - let@ () = WellTyped.Exposed.check_ct loc (Sctypes.of_ctype_unsafe loc ct) in + let@ () = WellTyped.check_ct loc (Sctypes.of_ctype_unsafe loc ct) in check_ptrval loc ~expect ptrval) (fun mem_values -> let@ index_bt, item_bt = expect_must_be_map_bt loc ~expect in @@ -143,7 +143,7 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : let@ values = ListM.mapM (check_mem_value loc ~expect:item_bt) mem_values in return (make_array_ ~index_bt ~item_bt values loc)) (fun tag mvals -> - let@ () = WellTyped.Exposed.check_ct loc (Struct tag) in + let@ () = WellTyped.check_ct loc (Struct tag) in let@ () = ensure_base_type loc ~expect (Struct tag) in let mvals = List.map (fun (id, ct, mv) -> (id, Sctypes.of_ctype_unsafe loc ct, mv)) mvals @@ -234,7 +234,7 @@ let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = | Vctype ct -> let@ () = ensure_base_type loc ~expect CType in let ct = Sctypes.of_ctype_unsafe loc ct in - let@ () = WellTyped.Exposed.check_ct loc ct in + let@ () = WellTyped.check_ct loc ct in return (IT.const_ctype_ ct loc) | Vunit -> let@ () = ensure_base_type loc ~expect Unit in @@ -325,7 +325,7 @@ let try_prove_constant loc expr = let check_single_ct loc expr = - let@ _pointer = WellTyped.Exposed.check_term loc BT.CType expr in + let@ _pointer = WellTyped.check_term loc BT.CType expr in let@ t = try_prove_constant loc expr in match IT.is_const t with | Some (IT.CType_const ct, _) -> return ct @@ -583,9 +583,9 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | Civfromfloat _ -> unsupported loc !^"floats" | PEarray_shift (pe1, ct, pe2) -> let@ () = ensure_base_type loc ~expect (Loc ()) in - let@ () = WellTyped.Exposed.check_ct loc ct in + let@ () = WellTyped.check_ct loc ct in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> (* NOTE: This case should not be present - only PtrArrayShift. The issue @@ -644,8 +644,8 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = (match op with | OpDiv -> let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.Exposed.ensure_bits_type loc expect in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_bits_type loc expect in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> let@ provable = provable loc in @@ -659,8 +659,8 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } }))) | OpRem_t -> let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.Exposed.ensure_bits_type loc expect in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_bits_type loc expect in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> let@ provable = provable loc in @@ -718,9 +718,9 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (or_ [ v1; v2 ] loc))) | OpAdd -> not_yet "OpAdd" | OpSub -> - let@ () = WellTyped.Exposed.ensure_bits_type loc expect in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_bits_type loc expect in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (sub_ (v1, v2) loc))) | OpMul -> not_yet "OpMul" | OpRem_f -> not_yet "OpRem_f" @@ -729,7 +729,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ () = match Mu.fun_return_type fun_id args with | Some (`Returns_BT bt) -> ensure_base_type loc ~expect bt - | Some `Returns_Integer -> WellTyped.Exposed.ensure_bits_type loc expect + | Some `Returns_Integer -> WellTyped.ensure_bits_type loc expect | None -> fail (fun _ -> { loc; @@ -757,7 +757,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ res = CLogicalFuns.eval_fun fun_id args orig_pe in k res) | PEstruct (tag, xs) -> - let@ () = WellTyped.Exposed.check_ct loc (Struct tag) in + let@ () = WellTyped.check_ct loc (Struct tag) in let@ () = ensure_base_type loc ~expect (Struct tag) in let@ layout = get_struct_decl loc tag in let member_types = Memory.member_types layout in @@ -796,15 +796,15 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | PEbounded_binop (Bound_Wrap act, iop, pe1, pe2) -> (* in integers, perform this op and round. in bitvector types, just perform the op (for all the ops where wrapping is consistent) *) - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in assert ( match act.ct with | Integer ity when Sctypes.is_unsigned_integer_type ity -> true | _ -> false); let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.Exposed.ensure_bits_type loc expect in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_bits_type loc expect in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in let@ () = match iop with | IOpShl | IOpShr -> return () @@ -841,12 +841,12 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in k x)) | PEbounded_binop (Bound_Except act, iop, pe1, pe2) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let ity = match act.ct with Integer ity -> ity | _ -> assert false in let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.Exposed.ensure_bits_type loc expect in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_bits_type loc expect in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in let@ () = match iop with | IOpShl | IOpShr -> return () @@ -890,27 +890,27 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = k direct_x)) | PEconv_int (ct_expr, pe) | PEconv_loaded_int (ct_expr, pe) -> let@ () = ensure_base_type loc ~expect:CType (Mu.bt_of_pexpr ct_expr) in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr ct_expr (fun ct_it -> let@ ct = check_single_ct loc ct_it in - let@ () = WellTyped.Exposed.check_ct loc ct in + let@ () = WellTyped.check_ct loc ct in let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct ct) in check_pexpr pe (fun lvt -> let@ vt = check_conv_int loc ~expect ct lvt in k vt)) | PEwrapI (act, pe) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.check_ct act.loc act.ct in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let bt = Memory.bt_of_sct act.ct in - let@ () = WellTyped.Exposed.ensure_bits_type loc bt in + let@ () = WellTyped.ensure_bits_type loc bt in k (cast_ bt arg loc)) | PEcatch_exceptional_condition (act, pe) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.check_ct act.loc act.ct in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let bt = Memory.bt_of_sct act.ct in - let@ () = WellTyped.Exposed.ensure_bits_type loc bt in + let@ () = WellTyped.ensure_bits_type loc bt in let ity = Option.get (Sctypes.is_integer_type act.ct) in let@ provable = provable loc in match provable (LC.T (is_representable_integer arg ity)) with @@ -920,9 +920,9 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let ub = CF.Undefined.UB036_exceptional_condition in fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } })) | PEis_representable_integer (pe, act) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect Bool in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in let ity = Option.get (Sctypes.is_integer_type act.ct) in check_pexpr pe (fun arg -> k (is_representable_integer arg ity)) | PEif (pe, e1, e2) -> @@ -1077,7 +1077,7 @@ end = struct let check_arg_it (loc, it_arg) ~(expect : BT.t) k = - let@ it_arg = WellTyped.Exposed.check_term loc expect it_arg in + let@ it_arg = WellTyped.check_term loc expect it_arg in k it_arg @@ -1285,7 +1285,7 @@ let add_trace_information _labels annots = let bytes_qpred sym size pointer init : Req.QPredicate.t = let here = Locations.other __LOC__ in - let bt' = WellTyped.Exposed.default_quantifier_bt in + let bt' = WellTyped.default_quantifier_bt in { q = (sym, bt'); q_loc = here; step = IT.num_lit_ Z.one bt' here; @@ -1411,7 +1411,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrLe (pe1, pe2) -> pointer_op (Fun.flip lePointer_ loc) pe1 pe2 | PtrGe (pe1, pe2) -> pointer_op (Fun.flip gePointer_ loc) pe1 pe2 | Ptrdiff (act, pe1, pe2) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct (Integer Ptrdiff_t)) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in @@ -1440,8 +1440,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in k result)) | IntFromPtr (act_from, act_to, pe) -> - let@ () = WellTyped.Exposed.check_ct act_from.loc act_from.ct in - let@ () = WellTyped.Exposed.check_ct act_to.loc act_to.ct in + let@ () = WellTyped.check_ct act_from.loc act_from.ct in + let@ () = WellTyped.check_ct act_to.loc act_to.ct in assert (match act_to.ct with Integer _ -> true | _ -> false); let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act_to.ct) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in @@ -1467,8 +1467,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in k actual_value) | PtrFromInt (act_from, act_to, pe) -> - let@ () = WellTyped.Exposed.check_ct act_from.loc act_from.ct in - let@ () = WellTyped.Exposed.check_ct act_to.loc act_to.ct in + let@ () = WellTyped.check_ct act_from.loc act_from.ct in + let@ () = WellTyped.check_ct act_to.loc act_to.ct in let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = ensure_base_type @@ -1495,7 +1495,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k result) | PtrValidForDeref (act, pe) -> (* TODO (DCM, VIP) *) - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect Bool in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in (* TODO (DCM, VIP): error if called on Void or Function Ctype. @@ -1510,7 +1510,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let result = aligned_ (arg, act.ct) loc in k result) | PtrWellAligned (act, pe) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect Bool in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in (* TODO (DCM, VIP): error if called on Void or Function Ctype *) @@ -1522,8 +1522,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrArrayShift (pe1, act, pe2) -> let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.check_ct act.loc act.ct in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> let result = @@ -1570,9 +1570,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Eaction (Paction (_pol, Action (_aloc, action_))) -> (match action_ with | Create (pe, act, prefix) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect (Loc ()) in - let@ () = WellTyped.Exposed.ensure_bits_type loc (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let ret_s, ret = match prefix with @@ -1621,7 +1621,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (* TODO (DCM, VIP) *) Cerb_debug.error "todo: Free" | Kill (Static ct, pe) -> - let@ () = WellTyped.Exposed.check_ct loc ct in + let@ () = WellTyped.check_ct loc ct in let@ () = ensure_base_type loc ~expect Unit in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> @@ -1637,7 +1637,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = record_action (Kill arg, loc) in k (unit_ loc)) | Store (_is_locking, act, p_pe, v_pe, _mo) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect Unit in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) in let@ () = @@ -1679,7 +1679,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = record_action (Write (parg, varg), loc) in k (unit_ loc))) | Load (act, p_pe, _mo) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) in check_pexpr p_pe (fun pointer -> @@ -1699,7 +1699,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = ensure_base_type loc ~expect Unit in k (unit_ loc) | Eccall (act, f_pe, pes) -> - let@ () = WellTyped.Exposed.check_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in (* copied TS's, from wellTyped.ml *) (* let@ (_ret_ct, _arg_cts) = match act.ct with *) (* | Pointer (Function (ret_v_ct, arg_r_cts, is_variadic)) -> *) @@ -1796,7 +1796,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let rhs = let[@ocaml.warning "-8"] (b :: bytes) = List.init (Memory.size_of_integer_type it) (fun i -> - let index = int_lit_ i WellTyped.Exposed.default_quantifier_bt here in + let index = int_lit_ i WellTyped.default_quantifier_bt here in let casted = cast_ bt (map_get_ byte_arr index here) here in let shift_amt = int_lit_ (i * 8) bt here in IT.IT (Binop (ShiftLeft, casted, shift_amt), bt, here)) @@ -1806,7 +1806,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = eq_ (lhs, rhs) here | Pointer _ -> (* FIXME this totally ignores provenances *) - let bt = WellTyped.Exposed.default_quantifier_bt in + let bt = WellTyped.default_quantifier_bt in let lhs = cast_ bt value here in let rhs = let[@ocaml.warning "-8"] (b :: bytes) = @@ -1830,7 +1830,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | To_from_bytes ((To | From), { name = PName _; _ }) -> fail (fun _ -> { loc; msg = Byte_conv_needs_owned }) | To_from_bytes (To, { name = Owned (ct, init); pointer; _ }) -> - let@ pointer = WellTyped.Exposed.infer_term pointer in + let@ pointer = WellTyped.infer_term pointer in let@ (_, O value), _ = RI.Special.predicate_request loc @@ -1838,7 +1838,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (bytes_pred ct pointer init, None) in let q_sym = Sym.fresh_named "to_bytes" in - let bt = WellTyped.Exposed.default_quantifier_bt in + let bt = WellTyped.default_quantifier_bt in let map_bt = BT.Map (bt, Memory.bt_of_sct Sctypes.uchar_ct) in let byte_sym, byte_arr = IT.fresh_named map_bt "byte_arr" here in let@ () = add_a byte_sym map_bt (loc, lazy (Pp.string "byte array")) in @@ -1847,7 +1847,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Uninit -> add_c loc (LC.T (IT.eq_ (byte_arr, default_ map_bt here) here)) | Init -> add_c loc (LC.T (bytes_constraints ~value ~byte_arr ct))) | To_from_bytes (From, { name = Owned (ct, init); pointer; _ }) -> - let@ pointer = WellTyped.Exposed.infer_term pointer in + let@ pointer = WellTyped.infer_term pointer in let q_sym = Sym.fresh_named "from_bytes" in let@ (_, O byte_arr), _ = RI.Special.qpredicate_request @@ -1869,7 +1869,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Uninit -> add_c loc (LC.T (IT.eq_ (value, default_ value_bt here) here)) | Init -> add_c loc (LC.T (bytes_constraints ~value ~byte_arr ct))) | Have lc -> - let@ _lc = WellTyped.Exposed.logical_constraint loc lc in + let@ _lc = WellTyped.logical_constraint loc lc in fail (fun _ -> { loc; msg = Generic !^"todo: 'have' not implemented yet" }) | Instantiate (to_instantiate, it) -> let@ filter = @@ -1879,10 +1879,10 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ _ = get_logical_function_def loc f in return (IT.mentions_call f) | I_Good ct -> - let@ () = WellTyped.Exposed.check_ct loc ct in + let@ () = WellTyped.check_ct loc ct in return (IT.mentions_good ct) in - let@ it = WellTyped.Exposed.infer_term it in + let@ it = WellTyped.infer_term it in instantiate loc filter it | Split_case _ -> assert false | Extract (attrs, to_extract, it) -> @@ -1895,19 +1895,19 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let msg = "'extract' requires a C-type annotation for 'Owned'" in fail (fun _ -> { loc; msg = Generic !^msg }) | E_Pred (CN_owned (Some ct)) -> - let@ () = WellTyped.Exposed.check_ct loc ct in + let@ () = WellTyped.check_ct loc ct in return (Request.Owned (ct, Init)) | E_Pred (CN_block None) -> let msg = "'extract' requires a C-type annotation for 'Block'" in fail (fun _ -> { loc; msg = Generic !^msg }) | E_Pred (CN_block (Some ct)) -> - let@ () = WellTyped.Exposed.check_ct loc ct in + let@ () = WellTyped.check_ct loc ct in return (Request.Owned (ct, Uninit)) | E_Pred (CN_named pn) -> let@ _ = get_resource_predicate_def loc pn in return (Request.PName pn) in - let@ it = WellTyped.Exposed.infer_term it in + let@ it = WellTyped.infer_term it in let@ original_rs, _ = all_resources_tagged loc in (* let verbose = List.exists (Id.is_str "verbose") attrs in *) let quiet = List.exists (Id.equal_string "quiet") attrs in @@ -1925,7 +1925,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ def = get_logical_function_def loc f in let has_args, expect_args = (List.length args, List.length def.args) in let@ () = - WellTyped.Exposed.ensure_same_argument_number + WellTyped.ensure_same_argument_number loc `General has_args @@ -1934,7 +1934,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ args = ListM.map2M (fun has_arg (_, def_arg_bt) -> - WellTyped.Exposed.check_term loc def_arg_bt has_arg) + WellTyped.check_term loc def_arg_bt has_arg) args def.args in @@ -1959,7 +1959,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = bind_logical_return loc members lrt in return ()) | Assert lc -> - let@ lc = WellTyped.Exposed.logical_constraint loc lc in + let@ lc = WellTyped.logical_constraint loc lc in let@ provable = provable loc in (match provable lc with | `True -> return () @@ -1976,7 +1976,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = })) | Inline _nms -> return () | Print it -> - let@ it = WellTyped.Exposed.infer_term it in + let@ it = WellTyped.infer_term it in let@ simp_ctxt = simp_ctxt () in let it = Simplify.IndexTerms.simp simp_ctxt it in print stdout (item "printed" (IT.pp it)); @@ -1985,8 +1985,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let rec loop = function | [] -> k (unit_ loc) | Cnprog.Let (loc, (sym, { ct; pointer }), cn_prog) :: cn_progs -> - let@ pointer = WellTyped.Exposed.check_term loc (Loc ()) pointer in - let@ () = WellTyped.Exposed.check_ct loc ct in + let@ pointer = WellTyped.check_term loc (Loc ()) pointer in + let@ () = WellTyped.check_ct loc ct in let@ value = load loc pointer ct in let subbed = Cnprog.subst (IT.make_subst [ (sym, value) ]) cn_prog in loop (subbed :: cn_progs) @@ -1994,7 +1994,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (match cn_statement with | Cnprog.Split_case lc -> Pp.debug 5 (lazy (Pp.headline "checking split_case")); - let@ lc = WellTyped.Exposed.logical_constraint loc lc in + let@ lc = WellTyped.logical_constraint loc lc in let@ it = match lc with | T it -> return it @@ -2119,7 +2119,7 @@ let check_procedure pure (let@ () = modify_where (Where.set_function fsym) in let@ (body, label_defs, rt), initial_resources = bind_arguments loc args_and_body in - let label_context = WellTyped.Exposed.label_context rt label_defs in + let label_context = WellTyped.label_context rt label_defs in let label_defs = Pmap.bindings_list label_defs in let@ (), _mete_pre_state = debug 2 (lazy (headline ("checking function body " ^ Sym.pp_string fsym))); @@ -2190,7 +2190,7 @@ let check_tagdefs tagDefs = (* this should have been checked earlier by the frontend *) assert false | Some (name, ct) -> - let@ () = WellTyped.Exposed.check_ct (Loc.other __LOC__) ct in + let@ () = WellTyped.check_ct (Loc.other __LOC__) ct in return (IdSet.add name have) | None -> return have) layout @@ -2210,7 +2210,7 @@ let record_and_check_logical_functions funs = let@ () = ListM.iterM (fun (name, def) -> - let@ simple_def = WellTyped.Exposed.function_ { def with body = Uninterp } in + let@ simple_def = WellTyped.function_ { def with body = Uninterp } in add_logical_function name simple_def) recursive in @@ -2225,7 +2225,7 @@ let record_and_check_logical_functions funs = ^ Pp.of_total i n_funs ^ ": " ^ Sym.pp_string name))); - let@ def = WellTyped.Exposed.function_ def in + let@ def = WellTyped.function_ def in add_logical_function name def) funs @@ -2235,7 +2235,7 @@ let record_and_check_resource_predicates preds = let@ () = ListM.iterM (fun (name, def) -> - let@ simple_def = WellTyped.Exposed.predicate { def with clauses = None } in + let@ simple_def = WellTyped.predicate { def with clauses = None } in add_resource_predicate name simple_def) preds in @@ -2249,7 +2249,7 @@ let record_and_check_resource_predicates preds = ^ Pp.of_total i (List.length preds) ^ ": " ^ Sym.pp_string name))); - let@ def = WellTyped.Exposed.predicate def in + let@ def = WellTyped.predicate def in (* add simplified def to the context *) add_resource_predicate name def) preds @@ -2261,7 +2261,7 @@ let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> LC.t list m = (fun acc (sym, def) -> match def with | Mu.GlobalDef (ct, _) | GlobalDecl ct -> - let@ () = WellTyped.Exposed.check_ct (Loc.other __LOC__) ct in + let@ () = WellTyped.check_ct (Loc.other __LOC__) ct in let bt = BT.(Loc ()) in let info = (Loc.other __LOC__, lazy (Pp.item "global" (Sym.pp sym))) in let@ () = add_a sym bt info in @@ -2327,8 +2327,8 @@ let wf_check_and_record_functions funs call_sigs = match def with | Mu.Proc { loc; args_and_body; trusted = tr; _ } -> welltyped_ping i fsym; - let@ args_and_body = WellTyped.Exposed.procedure loc args_and_body in - let ft = WellTyped.Exposed.to_argument_type args_and_body in + let@ args_and_body = WellTyped.procedure loc args_and_body in + let ft = WellTyped.to_argument_type args_and_body in debug 6 (lazy (!^"function type" ^^^ Sym.pp fsym)); debug 6 (lazy (CF.Pp_ast.pp_doc_tree (AT.dtree RT.dtree ft))); let@ () = add_fun_decl fsym (loc, Some ft, Pmap.find fsym call_sigs) in @@ -2341,7 +2341,7 @@ let wf_check_and_record_functions funs call_sigs = match oft with | None -> return None | Some ft -> - let@ ft = WellTyped.Exposed.function_type "function" loc ft in + let@ ft = WellTyped.function_type "function" loc ft in return (Some ft) in let@ () = add_fun_decl fsym (loc, oft, Pmap.find fsym call_sigs) in @@ -2455,7 +2455,7 @@ let check_c_functions (funs : c_function list) : (string * TypeErrors.t) list m (* (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list *) let wf_check_and_record_lemma (lemma_s, (loc, lemma_typ)) = - let@ lemma_typ = WellTyped.Exposed.lemma loc lemma_s lemma_typ in + let@ lemma_typ = WellTyped.lemma loc lemma_s lemma_typ in let@ () = add_lemma lemma_s (loc, lemma_typ) in return (lemma_s, (loc, lemma_typ)) @@ -2512,7 +2512,7 @@ let memcpy_proxy_ft = let src_sym, src = IT.fresh_named (BT.Loc ()) "src" here in let n_sym, n = IT.fresh_named Memory.size_bt "n" here in (* requires *) - let q_bt = WellTyped.Exposed.default_quantifier_bt in + let q_bt = WellTyped.default_quantifier_bt in let uchar_bt = Memory.bt_of_sct Sctypes.uchar_ct in let map_bt = BT.Map (q_bt, uchar_bt) in let destIn_sym, _ = IT.fresh_named map_bt "destIn" here in @@ -2594,8 +2594,8 @@ let record_and_check_datatypes datatypes = datatypes in (* check and normalise datatypes *) - let@ datatypes = ListM.mapM WellTyped.Exposed.datatype datatypes in - let@ sccs = WellTyped.Exposed.datatype_recursion datatypes in + let@ datatypes = ListM.mapM WellTyped.datatype datatypes in + let@ sccs = WellTyped.datatype_recursion datatypes in let@ () = set_datatype_order (Some sccs) in (* properly add datatypes *) ListM.iterM diff --git a/backend/cn/lib/diagnostics.ml b/backend/cn/lib/diagnostics.ml index 9b143ee7e..b22277552 100644 --- a/backend/cn/lib/diagnostics.ml +++ b/backend/cn/lib/diagnostics.ml @@ -103,8 +103,8 @@ let split_eq x y = | IT.Apply (nm, xs), IT.Apply (nm2, ys) when Sym.equal nm nm2 -> Some (List.map2 (fun x y -> (x, y)) xs ys) | IT.Constructor (nm, xs), IT.Constructor (nm2, ys) when Sym.equal nm nm2 -> - let xs = List.sort WellTyped.Exposed.compare_by_fst_id xs in - let ys = List.sort WellTyped.Exposed.compare_by_fst_id ys in + let xs = List.sort WellTyped.compare_by_fst_id xs in + let ys = List.sort WellTyped.compare_by_fst_id ys in Some (List.map2 (fun (_, x) (_, y) -> (x, y)) xs ys) | _ -> None diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index d0e01a24d..07e11f63a 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -160,7 +160,7 @@ module General = struct = Pp.(debug 7 (lazy (item __LOC__ (Req.pp (P requested))))); let start_timing = Pp.time_log_start __LOC__ "" in - let@ oarg_bt = WellTyped.Exposed.oarg_bt_of_pred loc requested.name in + let@ oarg_bt = WellTyped.oarg_bt_of_pred loc requested.name in let@ provable = provable loc in let@ global = get_global () in let@ simp_ctxt = simp_ctxt () in @@ -384,7 +384,7 @@ module General = struct and qpredicate_request loc uiinfo (requested : Req.QPredicate.t) = let@ o_oarg = qpredicate_request_aux loc uiinfo requested in - let@ oarg_item_bt = WellTyped.Exposed.oarg_bt_of_pred loc requested.name in + let@ oarg_item_bt = WellTyped.oarg_bt_of_pred loc requested.name in match o_oarg with | None -> return None | Some (oarg, rw_time) -> diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index d2dea29e5..c54d5d946 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -871,12 +871,8 @@ module NoSolver = struct let lift = function Ok x -> return x | Error x -> fail (fun _ -> x) end -module Made = WellTyped.Make (NoSolver) - module WellTyped = struct - module Exposed = struct - type nonrec 'a t = 'a t - - include Made.Exposed - end + type nonrec 'a t = 'a t + include WellTyped.Make(NoSolver) + include Exposed end diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index c84f3e0e5..4bfda8cd6 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -181,8 +181,4 @@ val modify_where : (Where.t -> Where.t) -> unit m val init_solver : unit -> unit m -module NoSolver : Sigs.NoSolver with type 'a t = 'a t - -module WellTyped : sig - module Exposed : Sigs.Exposed with type 'a t = 'a t -end +module WellTyped : Sigs.Exposed with type 'a t = 'a t From 28532c8395f5c5c2af433acfe1c39c3f36097ace Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sun, 29 Dec 2024 01:15:54 +0000 Subject: [PATCH 139/148] CN: Make Sig.NoSolver.failure abstract --- backend/cn/lib/sigs.ml | 4 +++- backend/cn/lib/typing.ml | 5 ++++- backend/cn/lib/wellTyped.ml | 2 +- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/backend/cn/lib/sigs.ml b/backend/cn/lib/sigs.ml index 5e85c975c..60ab762a0 100644 --- a/backend/cn/lib/sigs.ml +++ b/backend/cn/lib/sigs.ml @@ -1,7 +1,7 @@ module type NoSolver = sig type 'a t - type failure = Context.t * Explain.log -> TypeErrors.t + type failure val return : 'a -> 'a t @@ -9,6 +9,8 @@ module type NoSolver = sig val pure : 'a t -> 'a t + val liftFail : TypeErrors.t -> failure + val fail : failure -> 'a t val bound_a : Sym.t -> bool t diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index c54d5d946..f529cdfac 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -830,6 +830,8 @@ module NoSolver = struct type nonrec failure = failure + let liftFail typeErr _ = typeErr + let return = return let bind = bind @@ -873,6 +875,7 @@ end module WellTyped = struct type nonrec 'a t = 'a t - include WellTyped.Make(NoSolver) + + include WellTyped.Make (NoSolver) include Exposed end diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 084612f50..2433d43c2 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -14,7 +14,7 @@ let use_ity = ref true module Make (Monad : Sigs.NoSolver) = struct open Monad -let fail typeErr = fail (fun _ -> typeErr) +let fail typeErr = fail (Monad.liftFail typeErr) open Effectful.Make (Monad) From f33e4b96ca63fabdacf6fa4384c3ecbb372786c8 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sun, 29 Dec 2024 14:47:53 +0000 Subject: [PATCH 140/148] CN: Factor out Global lookup functions This was ostensibly in prep for using it in WellTyped, but it turned out that Typing also benefits from a bit of tidying around this module too. --- backend/cn/lib/cLogicalFuns.ml | 8 +- backend/cn/lib/check.ml | 52 ++++---- backend/cn/lib/global.ml | 65 ++++++++++ backend/cn/lib/typing.ml | 226 +++++++++++++++++---------------- backend/cn/lib/typing.mli | 60 +++++---- 5 files changed, 244 insertions(+), 167 deletions(-) diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index ca243d21e..6ff498065 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -541,7 +541,7 @@ let rec symb_exec_expr ctxt state_vars expr = in if Sym.Map.mem nm ctxt.c_fun_pred_map then ( let loc, l_sym = Sym.Map.find nm ctxt.c_fun_pred_map in - let@ def = get_logical_function_def loc l_sym in + let@ def = Global.get_logical_function_def loc l_sym in rcval (IT.apply_ l_sym args_its def.Definition.Function.return_bt loc) state) else ( let bail = fail_fun_it "not a function with a pure/logical interpretation" in @@ -710,9 +710,9 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ let upd_def (loc, sym, def_tm) = let open Definition.Function in - let@ def = get_logical_function_def loc sym in + let@ def = Global.get_logical_function_def loc sym in match def.body with - | Uninterp -> add_logical_function sym { def with body = Def def_tm } + | Uninterp -> Global.add_logical_function sym { def with body = Def def_tm } | _ -> fail_n { loc; @@ -734,7 +734,7 @@ let add_logical_funs_from_c call_funinfo funs_to_convert funs = let@ conv_defs = ListM.mapM (fun Mu.{ c_fun_sym; loc; l_fun_sym } -> - let@ def = get_logical_function_def loc l_fun_sym in + let@ def = Global.get_logical_function_def loc l_fun_sym in let@ fbody = match Pmap.lookup c_fun_sym funs with | Some fbody -> return fbody diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 5dbb54d2a..4be62926c 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -99,7 +99,7 @@ let check_ptrval (loc : Locations.t) ~(expect : BT.t) (ptrval : pointer_value) : unsupported loc !^"invalid function pointer" | Some sym -> (* just to make sure it exists *) - let@ _fun_loc, _, _ = get_fun_decl loc sym in + let@ _fun_loc, _, _ = Global.get_fun_decl loc sym in (* the symbol of a function is the same as the symbol of its address *) let here = Locations.other __LOC__ in return (sym_ (sym, BT.(Loc ()), here))) @@ -158,7 +158,7 @@ and check_struct (member_values : (Id.t * Sctypes.t * mem_value) list) : IT.t m = - let@ layout = get_struct_decl loc tag in + let@ layout = Global.get_struct_decl loc tag in let member_types = Memory.member_types layout in assert ( List.for_all2 @@ -248,7 +248,7 @@ let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = | Vfunction_addr sym -> let@ () = ensure_base_type loc ~expect (Loc ()) in (* check it is a valid function address *) - let@ _ = get_fun_decl loc sym in + let@ _ = Global.get_fun_decl loc sym in return (IT.sym_ (sym, BT.(Loc ()), loc)) | Vlist (_item_cbt, vals) -> let item_bt = Mu.bt_of_value (List.hd vals) in @@ -337,7 +337,7 @@ let check_single_ct loc expr = let is_fun_addr global t = match IT.is_sym t with | Some (s, _) -> - if Sym.Map.mem s global.Global.fun_decls then + if Global.is_fun_decl global s then Some s else None @@ -351,7 +351,7 @@ let known_function_pointer loc p = match already_known with | Some _ -> (* no need to find more eqs *) return () | None -> - let global_funs = Sym.Map.bindings global.Global.fun_decls in + let@ global_funs = Global.get_fun_decls () in let fun_addrs = List.map (fun (sym, (loc, _, _)) -> IT.sym_ (sym, BT.(Loc ()), loc)) global_funs in @@ -611,7 +611,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ () = ensure_base_type loc ~expect (Loc ()) in let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun vt -> - let@ ct = get_struct_member_type loc tag member in + let@ ct = Global.get_struct_member_type loc tag member in let result = memberShift_ (vt, tag, member) loc in (* This should only be called after a PtrValidForDeref, so if we were willing to optimise, we could skip to [k result]. *) @@ -759,7 +759,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | PEstruct (tag, xs) -> let@ () = WellTyped.check_ct loc (Struct tag) in let@ () = ensure_base_type loc ~expect (Struct tag) in - let@ layout = get_struct_decl loc tag in + let@ layout = Global.get_struct_decl loc tag in let member_types = Memory.member_types layout in let@ _ = ListM.map2M @@ -781,7 +781,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = (* function vals are just symbols the same as the names of functions *) let@ sym = known_function_pointer loc ptr in (* need to conjure up the characterising 4-tuple *) - let@ _, _, c_sig = get_fun_decl loc sym in + let@ _, _, c_sig = Global.get_fun_decl loc sym in match IT.const_of_c_sig c_sig loc with | Some it -> k it | None -> @@ -1712,7 +1712,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = check_pexpr f_pe (fun f_it -> let@ _global = get_global () in let@ fsym = known_function_pointer loc f_it in - let@ _loc, opt_ft, _ = get_fun_decl loc fsym in + let@ _loc, opt_ft, _ = Global.get_fun_decl loc fsym in let@ ft = match opt_ft with | Some ft -> return ft @@ -1876,7 +1876,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = match to_instantiate with | I_Everything -> return (fun _ -> true) | I_Function f -> - let@ _ = get_logical_function_def loc f in + let@ _ = Global.get_logical_function_def loc f in return (IT.mentions_call f) | I_Good ct -> let@ () = WellTyped.check_ct loc ct in @@ -1904,7 +1904,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = WellTyped.check_ct loc ct in return (Request.Owned (ct, Uninit)) | E_Pred (CN_named pn) -> - let@ _ = get_resource_predicate_def loc pn in + let@ _ = Global.get_resource_predicate_def loc pn in return (Request.PName pn) in let@ it = WellTyped.infer_term it in @@ -1922,7 +1922,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (); return () | Unfold (f, args) -> - let@ def = get_logical_function_def loc f in + let@ def = Global.get_logical_function_def loc f in let has_args, expect_args = (List.length args, List.length def.args) in let@ () = WellTyped.ensure_same_argument_number @@ -1947,7 +1947,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Some body -> add_c loc (LC.T (eq_ (apply_ f args def.return_bt loc, body) loc))) | Apply (lemma, args) -> - let@ _loc, lemma_typ = get_lemma loc lemma in + let@ _loc, lemma_typ = Global.get_lemma loc lemma in let args = List.map (fun arg -> (loc, arg)) args in Spine.calltype_lemma loc ~lemma args lemma_typ (fun lrt -> let@ _, members = @@ -2171,7 +2171,7 @@ let record_tagdefs tagDefs = (fun tag def -> match def with | Mu.UnionDef -> unsupported (Loc.other __LOC__) !^"todo: union types" - | StructDef layout -> add_struct_decl tag layout) + | StructDef layout -> Global.add_struct_decl tag layout) tagDefs @@ -2211,7 +2211,7 @@ let record_and_check_logical_functions funs = ListM.iterM (fun (name, def) -> let@ simple_def = WellTyped.function_ { def with body = Uninterp } in - add_logical_function name simple_def) + Global.add_logical_function name simple_def) recursive in (* Now check all functions in order. *) @@ -2226,7 +2226,7 @@ let record_and_check_logical_functions funs = ^ ": " ^ Sym.pp_string name))); let@ def = WellTyped.function_ def in - add_logical_function name def) + Global.add_logical_function name def) funs @@ -2236,7 +2236,7 @@ let record_and_check_resource_predicates preds = ListM.iterM (fun (name, def) -> let@ simple_def = WellTyped.predicate { def with clauses = None } in - add_resource_predicate name simple_def) + Global.add_resource_predicate name simple_def) preds in ListM.iteriM @@ -2251,7 +2251,7 @@ let record_and_check_resource_predicates preds = ^ Sym.pp_string name))); let@ def = WellTyped.predicate def in (* add simplified def to the context *) - add_resource_predicate name def) + Global.add_resource_predicate name def) preds @@ -2331,7 +2331,7 @@ let wf_check_and_record_functions funs call_sigs = let ft = WellTyped.to_argument_type args_and_body in debug 6 (lazy (!^"function type" ^^^ Sym.pp fsym)); debug 6 (lazy (CF.Pp_ast.pp_doc_tree (AT.dtree RT.dtree ft))); - let@ () = add_fun_decl fsym (loc, Some ft, Pmap.find fsym call_sigs) in + let@ () = Global.add_fun_decl fsym (loc, Some ft, Pmap.find fsym call_sigs) in (match tr with | Trusted _ -> return ((fsym, (loc, ft)) :: trusted, checked) | Checked -> return (trusted, (fsym, (loc, args_and_body)) :: checked)) @@ -2344,7 +2344,7 @@ let wf_check_and_record_functions funs call_sigs = let@ ft = WellTyped.function_type "function" loc ft in return (Some ft) in - let@ () = add_fun_decl fsym (loc, oft, Pmap.find fsym call_sigs) in + let@ () = Global.add_fun_decl fsym (loc, oft, Pmap.find fsym call_sigs) in return (trusted, checked)) funs ([], []) @@ -2456,7 +2456,7 @@ let check_c_functions (funs : c_function list) : (string * TypeErrors.t) list m let wf_check_and_record_lemma (lemma_s, (loc, lemma_typ)) = let@ lemma_typ = WellTyped.lemma loc lemma_s lemma_typ in - let@ () = add_lemma lemma_s (loc, lemma_typ) in + let@ () = Global.add_lemma lemma_s (loc, lemma_typ) in return (lemma_s, (loc, lemma_typ)) @@ -2566,7 +2566,7 @@ let add_stdlib_spec = Pp.debug 2 (lazy (Pp.headline ("adding builtin spec for procedure " ^ Sym.pp_string fsym))); - add_fun_decl fsym (Locations.other __LOC__, Some ft, ct) + Global.add_fun_decl fsym (Locations.other __LOC__, Some ft, ct) in fun call_sigs fsym -> match @@ -2590,23 +2590,23 @@ let record_and_check_datatypes datatypes = let@ () = ListM.iterM (fun (s, Mu.{ loc = _; cases = _ }) -> - add_datatype s { constrs = []; all_params = [] }) + Global.add_datatype s { constrs = []; all_params = [] }) datatypes in (* check and normalise datatypes *) let@ datatypes = ListM.mapM WellTyped.datatype datatypes in let@ sccs = WellTyped.datatype_recursion datatypes in - let@ () = set_datatype_order (Some sccs) in + let@ () = Global.set_datatype_order (Some sccs) in (* properly add datatypes *) ListM.iterM (fun (s, Mu.{ loc = _; cases }) -> let@ () = - add_datatype + Global.add_datatype s { constrs = List.map fst cases; all_params = List.concat_map snd cases } in ListM.iterM - (fun (c, params) -> add_datatype_constr c { params; datatype_tag = s }) + (fun (c, params) -> Global.add_datatype_constr c { params; datatype_tag = s }) cases) datatypes diff --git a/backend/cn/lib/global.ml b/backend/cn/lib/global.ml index 3aa48779a..85975a877 100644 --- a/backend/cn/lib/global.ml +++ b/backend/cn/lib/global.ml @@ -34,10 +34,75 @@ let get_fun_decl global sym = Sym.Map.find_opt sym global.fun_decls let get_lemma global sym = Sym.Map.find_opt sym global.lemmata +let get_struct_decl global sym = Sym.Map.find_opt sym global.struct_decls + +let get_datatype global sym = Sym.Map.find_opt sym global.datatypes + +let get_datatype_constr global sym = Sym.Map.find_opt sym global.datatype_constrs + let sym_map_from_bindings xs = List.fold_left (fun m (nm, x) -> Sym.Map.add nm x m) Sym.Map.empty xs +module type Reader = sig + type global = t + + type 'a t + + val return : 'a -> 'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + type state + + val get : unit -> state t + + val to_global : state -> global +end + +module type Lifted = sig + type 'a t + + val get_resource_predicate_def : Sym.t -> Definition.Predicate.t option t + + val get_logical_function_def : Sym.t -> Definition.Function.t option t + + val get_fun_decl + : Sym.t -> + (Cerb_location.t * AT.ft option * Sctypes.c_concrete_sig) option t + + val get_lemma : Sym.t -> (Cerb_location.t * AT.lemmat) option t + + val get_struct_decl : Sym.t -> Memory.struct_layout option t + + val get_datatype : Sym.t -> BaseTypes.dt_info option t + + val get_datatype_constr : Sym.t -> BaseTypes.constr_info option t +end + +module Lift (M : Reader) : Lifted with type 'a t := 'a M.t = struct + let lift f sym = + let ( let@ ) = M.bind in + let@ state = M.get () in + let global = M.to_global state in + M.return (f global sym) + + + let get_resource_predicate_def = lift get_resource_predicate_def + + let get_logical_function_def = lift get_logical_function_def + + let get_fun_decl = lift get_fun_decl + + let get_lemma = lift get_lemma + + let get_struct_decl = lift get_struct_decl + + let get_datatype = lift get_datatype + + let get_datatype_constr = lift get_datatype_constr +end + let pp_struct_layout (tag, layout) = item ("struct " ^ plain (Sym.pp tag) ^ " (raw)") diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index f529cdfac..eaecc0909 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -179,21 +179,11 @@ let print_with_ctxt printer = let get_global () : Global.t t = inspect_typing_context (fun c -> c.global) +(** TODO delete this, have Global.t be constructed by itself *) let set_global (g : Global.t) : unit t = modify_typing_context (fun s -> { s with global = g }) -(* later functions should be rewritten to use `inspect_global` and `modify_global` *) -let _inspect_global (f : Global.t -> 'a) : 'a t = - let@ g = get_global () in - return (f g) - - -let _modify_global (f : Global.t -> Global.t) : unit t = - let@ g = get_global () in - set_global (f g) - - let record_action ((a : Explain.action), (loc : Loc.t)) : unit t = modify (fun s -> { s with log = Action (a, loc) :: s.log }) @@ -205,135 +195,149 @@ let modify_where (f : Where.t -> Where.t) : unit t = { s with log; typing_context }) -(* convenient functions for global typing context *) - -let get_logical_function_def loc id = - let@ global = get_global () in - match Global.get_logical_function_def global id with - | Some def -> return def +(** TODO move the option part of this to Memory *) +let get_member_type loc member layout : Sctypes.t m = + let member_types = Memory.member_types layout in + match List.assoc_opt Id.equal member member_types with + | Some membertyp -> return membertyp | None -> - fail (fun _ -> - { loc; - msg = - Unknown_logical_function - { id; - resource = Option.is_some (Global.get_resource_predicate_def global id) - } - }) + fail (fun _ -> { loc; msg = Unexpected_member (List.map fst member_types, member) }) -let get_struct_decl loc tag = - let@ global = get_global () in - match Sym.Map.find_opt tag global.struct_decls with - | Some decl -> return decl - | None -> fail (fun _ -> { loc; msg = Unknown_struct tag }) +module Global = struct + include Global.Lift (struct + type nonrec 'a t = 'a t + let return = return -let get_datatype loc tag = - let@ global = get_global () in - match Sym.Map.find_opt tag global.datatypes with - | Some dt -> return dt - | None -> fail (fun _ -> { loc; msg = Unknown_datatype tag }) + let bind = bind + type state = s -let get_datatype_constr loc tag = - let@ global = get_global () in - match Sym.Map.find_opt tag global.datatype_constrs with - | Some info -> return info - | None -> fail (fun _ -> { loc; msg = Unknown_datatype_constr tag }) + type global = Global.t + let get = get -let get_member_type loc _tag member layout : Sctypes.t m = - let member_types = Memory.member_types layout in - match List.assoc_opt Id.equal member member_types with - | Some membertyp -> return membertyp - | None -> - fail (fun _ -> { loc; msg = Unexpected_member (List.map fst member_types, member) }) + let to_global (s : s) = s.typing_context.global + end) + let empty = Global.empty -let get_struct_member_type loc tag member = - let@ decl = get_struct_decl loc tag in - let@ ty = get_member_type loc tag member decl in - return ty + let is_fun_decl global id = Option.is_some @@ Global.get_fun_decl global id + let get_logical_function_def_opt id = get_logical_function_def id -let get_fun_decl loc fsym = - let@ global = get_global () in - match Global.get_fun_decl global fsym with - | Some t -> return t - | None -> fail (fun _ -> { loc; msg = Unknown_function fsym }) + let error_if_none opt loc msg = + let@ opt in + Option.fold + opt + ~some:return + ~none: + (let@ msg in + fail (fun _ -> { loc; msg })) -let get_lemma loc lsym = - let@ global = get_global () in - match Global.get_lemma global lsym with - | Some t -> return t - | None -> fail (fun _ -> { loc; msg = Unknown_lemma lsym }) + let get_logical_function_def loc id = + error_if_none + (get_logical_function_def id) + loc + (let@ res = get_resource_predicate_def id in + return (TypeErrors.Unknown_logical_function { id; resource = Option.is_some res })) -let get_resource_predicate_def loc id = - let@ global = get_global () in - match Global.get_resource_predicate_def global id with - | Some def -> return def - | None -> - fail (fun _ -> - { loc; - msg = - Unknown_resource_predicate - { id; logical = Option.is_some (Global.get_logical_function_def global id) } - }) + let get_struct_decl loc tag = + error_if_none (get_struct_decl tag) loc (return (TypeErrors.Unknown_struct tag)) -let add_struct_decl tag layout : unit m = - let@ global = get_global () in - set_global { global with struct_decls = Sym.Map.add tag layout global.struct_decls } + let get_datatype loc tag = + error_if_none (get_datatype tag) loc (return (TypeErrors.Unknown_datatype tag)) -let add_fun_decl fname entry = - let@ global = get_global () in - set_global { global with fun_decls = Sym.Map.add fname entry global.fun_decls } + let get_datatype_constr loc tag = + error_if_none + (get_datatype_constr tag) + loc + (return (TypeErrors.Unknown_datatype_constr tag)) -let add_lemma lemma_s (loc, lemma_typ) = - let@ global = get_global () in - set_global { global with lemmata = Sym.Map.add lemma_s (loc, lemma_typ) global.lemmata } + let get_struct_member_type loc tag member = + let@ decl = get_struct_decl loc tag in + let@ ty = get_member_type loc member decl in + return ty -let add_resource_predicate name entry = - let@ global = get_global () in - set_global - { global with - resource_predicates = Sym.Map.add name entry global.resource_predicates - } + let get_fun_decl loc fsym = + error_if_none (get_fun_decl fsym) loc (return (TypeErrors.Unknown_function fsym)) -let add_logical_function name entry = - let@ global = get_global () in - set_global - { global with logical_functions = Sym.Map.add name entry global.logical_functions } + let get_lemma loc lsym = + error_if_none (get_lemma lsym) loc (return (TypeErrors.Unknown_lemma lsym)) -let add_datatype name entry = - let@ global = get_global () in - set_global { global with datatypes = Sym.Map.add name entry global.datatypes } + let get_resource_predicate_def loc id = + error_if_none + (get_resource_predicate_def id) + loc + (let@ log = get_logical_function_def_opt id in + return (TypeErrors.Unknown_resource_predicate { id; logical = Option.is_some log })) -let add_datatype_constr name entry = - let@ global = get_global () in - set_global - { global with datatype_constrs = Sym.Map.add name entry global.datatype_constrs } + let get_fun_decls () = + let@ global = get_global () in + return (Sym.Map.bindings global.fun_decls) -let set_datatype_order datatype_order = - let@ g = get_global () in - set_global { g with datatype_order } + let add_struct_decl tag layout : unit m = + let@ global = get_global () in + set_global { global with struct_decls = Sym.Map.add tag layout global.struct_decls } -let get_datatype_order () = - let@ g = get_global () in - return g.datatype_order + let add_fun_decl fname entry = + let@ global = get_global () in + set_global { global with fun_decls = Sym.Map.add fname entry global.fun_decls } + let add_lemma lemma_s (loc, lemma_typ) = + let@ global = get_global () in + set_global + { global with lemmata = Sym.Map.add lemma_s (loc, lemma_typ) global.lemmata } + + + let add_resource_predicate name entry = + let@ global = get_global () in + set_global + { global with + resource_predicates = Sym.Map.add name entry global.resource_predicates + } + + + let add_logical_function name entry = + let@ global = get_global () in + set_global + { global with logical_functions = Sym.Map.add name entry global.logical_functions } + + + let add_datatype name entry = + let@ global = get_global () in + set_global { global with datatypes = Sym.Map.add name entry global.datatypes } + + + let add_datatype_constr name entry = + let@ global = get_global () in + set_global + { global with datatype_constrs = Sym.Map.add name entry global.datatype_constrs } + + + let set_datatype_order datatype_order = + let@ g = get_global () in + set_global { g with datatype_order } + + + let get_datatype_order () = + let@ g = get_global () in + return g.datatype_order +end + (* end: convenient functions for global typing context *) let add_sym_eqs sym_eqs = @@ -852,21 +856,21 @@ module NoSolver = struct let add_l = add_l - let get_struct_decl = get_struct_decl + let get_struct_decl = Global.get_struct_decl - let get_struct_member_type = get_struct_member_type + let get_struct_member_type = Global.get_struct_member_type - let get_datatype = get_datatype + let get_datatype = Global.get_datatype - let get_datatype_constr = get_datatype_constr + let get_datatype_constr = Global.get_datatype_constr - let get_resource_predicate_def = get_resource_predicate_def + let get_resource_predicate_def = Global.get_resource_predicate_def - let get_logical_function_def = get_logical_function_def + let get_logical_function_def = Global.get_logical_function_def - let get_lemma = get_lemma + let get_lemma = Global.get_lemma - let get_fun_decl = get_fun_decl + let get_fun_decl = Global.get_fun_decl let ensure_base_type = ensure_base_type diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 4bfda8cd6..3152e5ec3 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -80,10 +80,6 @@ val add_r : Locations.t -> Resource.t -> unit m val add_rs : Locations.t -> Resource.t list -> unit m -val set_datatype_order : Sym.t list list option -> unit m - -val get_datatype_order : unit -> Sym.t list list option m - val res_history : Locations.t -> int -> Context.resource_history m type changed = @@ -97,43 +93,55 @@ val map_and_fold_resources 'acc -> ('acc * int list) m -val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_decl m +module Global : sig + val empty : Global.t -val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.t m + val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_decl m -val get_member_type : Locations.t -> Sym.t -> Id.t -> Memory.struct_layout -> Sctypes.t m + val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.t m -val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info m + val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info m -val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info m + val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info m -val get_fun_decl - : Locations.t -> - Sym.t -> - (Locations.t * Global.AT.ft option * Sctypes.c_concrete_sig) m + val get_fun_decl + : Locations.t -> + Sym.t -> + (Locations.t * Global.AT.ft option * Sctypes.c_concrete_sig) m -val get_lemma : Locations.t -> Sym.t -> (Locations.t * Global.AT.lemmat) m + val add_lemma : Sym.t -> Locations.t * ArgumentTypes.lemmat -> unit m -val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t m + val get_lemma : Locations.t -> Sym.t -> (Locations.t * Global.AT.lemmat) m -val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t m + val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t m -val add_struct_decl : Sym.t -> Memory.struct_layout -> unit m + val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t m -val add_fun_decl - : Sym.t -> - Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig -> - unit m + val add_struct_decl : Sym.t -> Memory.struct_layout -> unit m + + val add_fun_decl + : Sym.t -> + Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig -> + unit m + + val set_datatype_order : Sym.t list list option -> unit m + + val get_datatype_order : unit -> Sym.t list list option m + + val add_resource_predicate : Sym.t -> Definition.Predicate.t -> unit m -val add_lemma : Sym.t -> Locations.t * ArgumentTypes.lemmat -> unit m + val add_logical_function : Sym.t -> Definition.Function.t -> unit m -val add_resource_predicate : Sym.t -> Definition.Predicate.t -> unit m + val add_datatype : Sym.t -> BaseTypes.dt_info -> unit m -val add_logical_function : Sym.t -> Definition.Function.t -> unit m + val add_datatype_constr : Sym.t -> BaseTypes.constr_info -> unit m -val add_datatype : Sym.t -> BaseTypes.dt_info -> unit m + val is_fun_decl : Global.t -> Sym.t -> bool -val add_datatype_constr : Sym.t -> BaseTypes.constr_info -> unit m + val get_fun_decls + : unit -> + (Sym.t * (Locations.t * Global.AT.ft option * Sctypes.c_concrete_sig)) list m +end (* val set_statement_locs : Locations.loc CStatements.LocMap.t -> (unit) m *) From 3dabed036419b92b0767e96fd759e1f87f7c5689 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sun, 29 Dec 2024 16:28:17 +0000 Subject: [PATCH 141/148] CN: Use simpler, custom monad for WellTyped This commit removes functor from around the implementation of WellTyped, and uses a simpler Error and Reader monad based only on Context.t, hence no solver. Like Global, it also provides an transformer functor to lift its exposed monadic API to a give target. --- backend/cn/lib/typing.ml | 78 +++---------- backend/cn/lib/wellTyped.ml | 215 ++++++++++++++++++++++++++++++++++- backend/cn/lib/wellTyped.mli | 22 +++- 3 files changed, 247 insertions(+), 68 deletions(-) diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index eaecc0909..a0334fa9c 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -195,7 +195,6 @@ let modify_where (f : Where.t -> Where.t) : unit t = { s with log; typing_context }) -(** TODO move the option part of this to Memory *) let get_member_type loc member layout : Sctypes.t m = let member_types = Memory.member_types layout in match List.assoc_opt Id.equal member member_types with @@ -204,22 +203,28 @@ let get_member_type loc member layout : Sctypes.t m = fail (fun _ -> { loc; msg = Unexpected_member (List.map fst member_types, member) }) -module Global = struct - include Global.Lift (struct - type nonrec 'a t = 'a t +module ErrorReader = struct + type nonrec 'a t = 'a t - let return = return + let return = return + + let bind = bind - let bind = bind + type state = s - type state = s + type global = Global.t - type global = Global.t + let get = get - let get = get + let to_global (s : s) = s.typing_context.global - let to_global (s : s) = s.typing_context.global - end) + let to_context (s : s) = s.typing_context + + let lift = lift +end + +module Global = struct + include Global.Lift (ErrorReader) let empty = Global.empty @@ -829,57 +834,8 @@ let test_value_eqs loc guard x ys = loop group ms ys -module NoSolver = struct - type nonrec 'a t = 'a t - - type nonrec failure = failure - - let liftFail typeErr _ = typeErr - - let return = return - - let bind = bind - - let pure = pure - - let fail = fail - - let bound_a = bound_a - - let bound_l = bound_l - - let get_a = get_a - - let get_l = get_l - - let add_a = add_a - - let add_l = add_l - - let get_struct_decl = Global.get_struct_decl - - let get_struct_member_type = Global.get_struct_member_type - - let get_datatype = Global.get_datatype - - let get_datatype_constr = Global.get_datatype_constr - - let get_resource_predicate_def = Global.get_resource_predicate_def - - let get_logical_function_def = Global.get_logical_function_def - - let get_lemma = Global.get_lemma - - let get_fun_decl = Global.get_fun_decl - - let ensure_base_type = ensure_base_type - - let lift = function Ok x -> return x | Error x -> fail (fun _ -> x) -end - module WellTyped = struct type nonrec 'a t = 'a t - include WellTyped.Make (NoSolver) - include Exposed + include WellTyped.Lift (ErrorReader) end diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 2433d43c2..d1a0eee8f 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -9,14 +9,133 @@ let squotes, warn, dot, string, debug, item, colon, comma = Pp.(squotes, warn, dot, string, debug, item, colon, comma) +module GlobalReader = struct + type 'a t = Context.t -> ('a * Context.t) Or_TypeError.t + + let return x s = Ok (x, s) + + let bind x f s = match x s with Ok (y, s') -> f y s' | Error err -> Error err + + let get () s = Ok (s, s) + + let to_global ctxt = ctxt.Context.global + + type global = Global.t + + type state = Context.t +end + +module NoSolver = struct + include GlobalReader + include Global.Lift (GlobalReader) + + type failure = TypeErrors.t + + let liftFail typeErr = typeErr + + let pure x s = match x s with Ok (y, _) -> Ok (y, s) | Error err -> Error err + + let fail (typeErr : failure) : 'a t = fun _ -> Error (liftFail typeErr) + + let update f s = Ok ((), f s) + + let lookup f : _ t = fun s -> Ok (f s, s) + + let ( let@ ) = bind + + let bound_a sym = lookup (Context.bound_a sym) + + let bound_l sym = lookup (Context.bound_l sym) + + let get_a sym = lookup (Context.get_a sym) + + let get_l sym = lookup (Context.get_l sym) + + let add_a sym bt info = update (Context.add_a sym bt info) + + let add_l sym bt info = update (Context.add_l sym bt info) + + let ensure_base_type loc ~expect has : unit t = + if BT.equal has expect then + return () + else + fail { loc; msg = Mismatch { has = BT.pp has; expect = BT.pp expect } } + + + let error_if_none opt loc msg = + let@ opt in + Option.fold + opt + ~some:return + ~none: + (let@ msg in + fail { loc; msg }) + + + let get_logical_function_def_opt id = get_logical_function_def id + + let get_logical_function_def loc id = + error_if_none + (get_logical_function_def id) + loc + (let@ res = get_resource_predicate_def id in + return (TypeErrors.Unknown_logical_function { id; resource = Option.is_some res })) + + + let get_struct_decl loc tag = + error_if_none (get_struct_decl tag) loc (return (TypeErrors.Unknown_struct tag)) + + + let get_datatype loc tag = + error_if_none (get_datatype tag) loc (return (TypeErrors.Unknown_datatype tag)) + + + let get_datatype_constr loc tag = + error_if_none + (get_datatype_constr tag) + loc + (return (TypeErrors.Unknown_datatype_constr tag)) + + + let get_member_type loc member layout : Sctypes.t t = + let member_types = Memory.member_types layout in + match List.assoc_opt Id.equal member member_types with + | Some membertyp -> return membertyp + | None -> fail { loc; msg = Unexpected_member (List.map fst member_types, member) } + + + let get_struct_member_type loc tag member = + let@ decl = get_struct_decl loc tag in + let@ ty = get_member_type loc member decl in + return ty + + + let get_fun_decl loc fsym = + error_if_none (get_fun_decl fsym) loc (return (TypeErrors.Unknown_function fsym)) + + + let get_lemma loc lsym = + error_if_none (get_lemma lsym) loc (return (TypeErrors.Unknown_lemma lsym)) + + + let get_resource_predicate_def loc id = + error_if_none + (get_resource_predicate_def id) + loc + (let@ log = get_logical_function_def_opt id in + return (TypeErrors.Unknown_resource_predicate { id; logical = Option.is_some log })) + + + let lift = function Ok x -> return x | Error x -> fail x +end + let use_ity = ref true -module Make (Monad : Sigs.NoSolver) = struct -open Monad +open NoSolver -let fail typeErr = fail (Monad.liftFail typeErr) +let fail typeErr = fail (NoSolver.liftFail typeErr) -open Effectful.Make (Monad) +open Effectful.Make (NoSolver) let illtyped_index_term (loc : Locations.t) it has ~expected ~reason = let reason = @@ -2394,4 +2513,90 @@ module Exposed = struct let ensure_bits_type = ensure_bits_type end -end[@@ocamlformat "disable"] + +module type ErrorReader = sig + type 'a t + + val return : 'a -> 'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + type state + + val get : unit -> state t + + val to_context : state -> Context.t + + val lift : 'a Or_TypeError.t -> 'a t +end + +module Lift (M : ErrorReader) : Sigs.Exposed with type 'a t := 'a M.t = struct + let lift1 f x = + let ( let@ ) = M.bind in + let@ state = M.get () in + let context = M.to_context state in + M.lift (Result.map fst (f x context)) + + + let lift2 f x y = + let ( let@ ) = M.bind in + let@ state = M.get () in + let context = M.to_context state in + M.lift (Result.map fst (f x y context)) + + + let lift3 f x y z = + let ( let@ ) = M.bind in + let@ state = M.get () in + let context = M.to_context state in + M.lift (Result.map fst (f x y z context)) + + + let datatype x = lift1 Exposed.datatype x + + let datatype_recursion = lift1 Exposed.datatype_recursion + + let lemma x y z = lift3 Exposed.lemma x y z + + let function_ = lift1 Exposed.function_ + + let predicate = lift1 Exposed.predicate + + let label_context = Exposed.label_context + + let to_argument_type = Exposed.to_argument_type + + let procedure x y = lift2 Exposed.procedure x y + + let integer_annot = Exposed.integer_annot + + let infer_expr x y = lift2 Exposed.infer_expr x y + + let check_expr x y z = lift3 Exposed.check_expr x y z + + let function_type = lift3 Exposed.function_type + + let logical_constraint = lift2 Exposed.logical_constraint + + let oarg_bt_of_pred = lift2 Exposed.oarg_bt_of_pred + + let default_quantifier_bt = Exposed.default_quantifier_bt + + let infer_term x = lift1 Exposed.infer_term x + + let check_term x y z = lift3 Exposed.check_term x y z + + let check_ct = lift2 Exposed.check_ct + + let compare_by_fst_id = Exposed.compare_by_fst_id + + let ensure_same_argument_number loc type_ n ~expect = + let ( let@ ) = M.bind in + let@ state = M.get () in + let context = M.to_context state in + M.lift + (Result.map fst (Exposed.ensure_same_argument_number loc type_ n ~expect context)) + + + let ensure_bits_type = lift2 Exposed.ensure_bits_type +end diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index 38d28f3d2..ef35fc3a2 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -1,5 +1,23 @@ val use_ity : bool ref -module Make : functor (Monad : Sigs.NoSolver) -> sig - module Exposed : Sigs.Exposed with type 'a t := 'a Monad.t +module NoSolver : Sigs.NoSolver + +module Exposed : Sigs.Exposed with type 'a t := 'a NoSolver.t + +module type ErrorReader = sig + type 'a t + + val return : 'a -> 'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + type state + + val get : unit -> state t + + val to_context : state -> Context.t + + val lift : 'a Or_TypeError.t -> 'a t end + +module Lift : functor (M : ErrorReader) -> Sigs.Exposed with type 'a t := 'a M.t From 0c0247efdee45c8d57bef8b0e61f8e42495690d3 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sun, 29 Dec 2024 17:10:27 +0000 Subject: [PATCH 142/148] CN: Remove WellTyped.Exposed and simplify intf This commit adds a slightly unfortunate wellTyped_intf.ml file so that the signatures contained therein can be use from multiple places. --- backend/cn/lib/typing.mli | 2 +- backend/cn/lib/wellTyped.ml | 99 ++++++++++--------- backend/cn/lib/wellTyped.mli | 6 +- backend/cn/lib/{sigs.ml => wellTyped_intf.ml} | 53 +--------- 4 files changed, 54 insertions(+), 106 deletions(-) rename backend/cn/lib/{sigs.ml => wellTyped_intf.ml} (59%) diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 3152e5ec3..e1e70e213 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -189,4 +189,4 @@ val modify_where : (Where.t -> Where.t) -> unit m val init_solver : unit -> unit m -module WellTyped : Sigs.Exposed with type 'a t = 'a t +module WellTyped : WellTyped_intf.S with type 'a t = 'a t diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index d1a0eee8f..14222bec2 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -9,8 +9,10 @@ let squotes, warn, dot, string, debug, item, colon, comma = Pp.(squotes, warn, dot, string, debug, item, colon, comma) +type 'a t = Context.t -> ('a * Context.t) Or_TypeError.t + module GlobalReader = struct - type 'a t = Context.t -> ('a * Context.t) Or_TypeError.t + type nonrec 'a t = 'a t let return x s = Ok (x, s) @@ -127,13 +129,15 @@ module NoSolver = struct let lift = function Ok x -> return x | Error x -> fail x + + let run ctxt x = x ctxt end let use_ity = ref true open NoSolver -let fail typeErr = fail (NoSolver.liftFail typeErr) +let fail typeErr = fail (liftFail typeErr) open Effectful.Make (NoSolver) @@ -2470,49 +2474,47 @@ module WDT = struct return sccs end -module Exposed = struct - let datatype = WDT.welltyped +let datatype = WDT.welltyped - let datatype_recursion = WDT.check_recursion_ok +let datatype_recursion = WDT.check_recursion_ok - let lemma = WLemma.welltyped +let lemma = WLemma.welltyped - let function_ = WLFD.welltyped +let function_ = WLFD.welltyped - let predicate = WRPD.welltyped +let predicate = WRPD.welltyped - let label_context = WProc.label_context +let label_context = WProc.label_context - let to_argument_type = WProc.typ +let to_argument_type = WProc.typ - let procedure = WProc.welltyped +let procedure = WProc.welltyped - let integer_annot = BaseTyping.integer_annot +let integer_annot = BaseTyping.integer_annot - let infer_expr = BaseTyping.infer_expr +let infer_expr = BaseTyping.infer_expr - let check_expr = BaseTyping.check_expr +let check_expr = BaseTyping.check_expr - let function_type = WFT.welltyped +let function_type = WFT.welltyped - let logical_constraint = WLC.welltyped +let logical_constraint = WLC.welltyped - let oarg_bt_of_pred = WRS.oarg_bt_of_pred +let oarg_bt_of_pred = WRS.oarg_bt_of_pred - let default_quantifier_bt = quantifier_bt +let default_quantifier_bt = quantifier_bt - let infer_term = WIT.infer +let infer_term = WIT.infer - let check_term = WIT.check +let check_term = WIT.check - let check_ct = WCT.is_ct +let check_ct = WCT.is_ct - let compare_by_fst_id = compare_by_fst_id +let compare_by_fst_id = compare_by_fst_id - let ensure_same_argument_number = ensure_same_argument_number +let ensure_same_argument_number = ensure_same_argument_number - let ensure_bits_type = ensure_bits_type -end +let ensure_bits_type = ensure_bits_type module type ErrorReader = sig type 'a t @@ -2530,12 +2532,12 @@ module type ErrorReader = sig val lift : 'a Or_TypeError.t -> 'a t end -module Lift (M : ErrorReader) : Sigs.Exposed with type 'a t := 'a M.t = struct +module Lift (M : ErrorReader) : WellTyped_intf.S with type 'a t := 'a M.t = struct let lift1 f x = let ( let@ ) = M.bind in let@ state = M.get () in let context = M.to_context state in - M.lift (Result.map fst (f x context)) + M.lift (Result.map fst (run context (f x))) let lift2 f x y = @@ -2552,51 +2554,50 @@ module Lift (M : ErrorReader) : Sigs.Exposed with type 'a t := 'a M.t = struct M.lift (Result.map fst (f x y z context)) - let datatype x = lift1 Exposed.datatype x + let datatype x = lift1 datatype x - let datatype_recursion = lift1 Exposed.datatype_recursion + let datatype_recursion = lift1 datatype_recursion - let lemma x y z = lift3 Exposed.lemma x y z + let lemma x y z = lift3 lemma x y z - let function_ = lift1 Exposed.function_ + let function_ = lift1 function_ - let predicate = lift1 Exposed.predicate + let predicate = lift1 predicate - let label_context = Exposed.label_context + let label_context = label_context - let to_argument_type = Exposed.to_argument_type + let to_argument_type = to_argument_type - let procedure x y = lift2 Exposed.procedure x y + let procedure x y = lift2 procedure x y - let integer_annot = Exposed.integer_annot + let integer_annot = integer_annot - let infer_expr x y = lift2 Exposed.infer_expr x y + let infer_expr x y = lift2 infer_expr x y - let check_expr x y z = lift3 Exposed.check_expr x y z + let check_expr x y z = lift3 check_expr x y z - let function_type = lift3 Exposed.function_type + let function_type = lift3 function_type - let logical_constraint = lift2 Exposed.logical_constraint + let logical_constraint = lift2 logical_constraint - let oarg_bt_of_pred = lift2 Exposed.oarg_bt_of_pred + let oarg_bt_of_pred = lift2 oarg_bt_of_pred - let default_quantifier_bt = Exposed.default_quantifier_bt + let default_quantifier_bt = default_quantifier_bt - let infer_term x = lift1 Exposed.infer_term x + let infer_term x = lift1 infer_term x - let check_term x y z = lift3 Exposed.check_term x y z + let check_term x y z = lift3 check_term x y z - let check_ct = lift2 Exposed.check_ct + let check_ct = lift2 check_ct - let compare_by_fst_id = Exposed.compare_by_fst_id + let compare_by_fst_id = compare_by_fst_id let ensure_same_argument_number loc type_ n ~expect = let ( let@ ) = M.bind in let@ state = M.get () in let context = M.to_context state in - M.lift - (Result.map fst (Exposed.ensure_same_argument_number loc type_ n ~expect context)) + M.lift (Result.map fst (ensure_same_argument_number loc type_ n ~expect context)) - let ensure_bits_type = lift2 Exposed.ensure_bits_type + let ensure_bits_type = lift2 ensure_bits_type end diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index ef35fc3a2..762140161 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -1,8 +1,6 @@ val use_ity : bool ref -module NoSolver : Sigs.NoSolver - -module Exposed : Sigs.Exposed with type 'a t := 'a NoSolver.t +include WellTyped_intf.S module type ErrorReader = sig type 'a t @@ -20,4 +18,4 @@ module type ErrorReader = sig val lift : 'a Or_TypeError.t -> 'a t end -module Lift : functor (M : ErrorReader) -> Sigs.Exposed with type 'a t := 'a M.t +module Lift : functor (M : ErrorReader) -> WellTyped_intf.S with type 'a t := 'a M.t diff --git a/backend/cn/lib/sigs.ml b/backend/cn/lib/wellTyped_intf.ml similarity index 59% rename from backend/cn/lib/sigs.ml rename to backend/cn/lib/wellTyped_intf.ml index 60ab762a0..f16432e1a 100644 --- a/backend/cn/lib/sigs.ml +++ b/backend/cn/lib/wellTyped_intf.ml @@ -1,55 +1,4 @@ -module type NoSolver = sig - type 'a t - - type failure - - val return : 'a -> 'a t - - val bind : 'a t -> ('a -> 'b t) -> 'b t - - val pure : 'a t -> 'a t - - val liftFail : TypeErrors.t -> failure - - val fail : failure -> 'a t - - val bound_a : Sym.t -> bool t - - val bound_l : Sym.t -> bool t - - val get_a : Sym.t -> Context.basetype_or_value t - - val get_l : Sym.t -> Context.basetype_or_value t - - val add_a : Sym.t -> BaseTypes.t -> Context.l_info -> unit t - - val add_l : Sym.t -> BaseTypes.t -> Context.l_info -> unit t - - val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_layout t - - val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.ctype t - - val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info t - - val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info t - - val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t t - - val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t t - - val get_lemma : Locations.t -> Sym.t -> (Locations.t * ArgumentTypes.lemmat) t - - val get_fun_decl - : Locations.t -> - Sym.t -> - (Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig) t - - val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit t - - val lift : 'a Or_TypeError.t -> 'a t -end - -module type Exposed = sig +module type S = sig type 'a t val ensure_bits_type : Locations.t -> BaseTypes.t -> unit t From 580b35605f368468cdf4e7709e9e4f59972bc693 Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sun, 29 Dec 2024 18:24:29 +0000 Subject: [PATCH 143/148] CN: Reduce code dup. for Global related errs Because of the split between WellTyped and Typing, the code for handling lookups in Global was duplicated across the two. This commit adjusts the API exposed by Global to avoid duplicating the error handling logic. It also needs to move Global-specific errors out of TypeErrors and into Global to avoid a circular dependency. (TypeErrors depends on Context which depends on Global, so Global cannot reference TypeErrors types). --- backend/cn/lib/cLogicalFuns.ml | 2 +- backend/cn/lib/check.ml | 2 +- backend/cn/lib/compile.ml | 15 ++- backend/cn/lib/global.ml | 80 ++++++++----- backend/cn/lib/typeErrors.ml | 34 ++---- backend/cn/lib/typeErrors.mli | 16 +-- backend/cn/lib/typing.ml | 63 ++-------- backend/cn/lib/wellTyped.ml | 113 ++++-------------- backend/cn/lib/wellTyped.mli | 6 +- tests/cn/tree16/as_mutual_dt/tree16.c.verify | 4 +- .../cn/tree16/as_partial_map/tree16.c.verify | 4 +- 11 files changed, 112 insertions(+), 227 deletions(-) diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index 6ff498065..a97eac804 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -738,7 +738,7 @@ let add_logical_funs_from_c call_funinfo funs_to_convert funs = let@ fbody = match Pmap.lookup c_fun_sym funs with | Some fbody -> return fbody - | None -> fail_n { loc; msg = Unknown_function c_fun_sym } + | None -> fail_n { loc; msg = Global (Unknown_function c_fun_sym) } in let@ it = c_fun_to_it loc global_context l_fun_sym c_fun_sym def fbody in Pp.debug diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 4be62926c..8fdb6ffd1 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -2611,7 +2611,7 @@ let record_and_check_datatypes datatypes = datatypes -(** Note: this does not check loop invariants and CN statements! *) +(** NOTE: not clear if this checks loop invariants and CN statements! *) let check_decls_lemmata_fun_specs (file : unit Mu.file) = Cerb_debug.begin_csv_timing (); (* decl, lemmata, function specification checking *) diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 76ddb603b..26b45c570 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -424,7 +424,7 @@ module EffectfulTranslation = struct let lookup_struct loc tag env = match lookup_struct_opt tag env with | Some def -> return def - | None -> fail { loc; msg = Unknown_struct tag } + | None -> fail { loc; msg = Global (Unknown_struct tag) } let lookup_member loc (_tag, def) member = @@ -437,13 +437,13 @@ module EffectfulTranslation = struct let lookup_datatype loc sym env = match Sym.Map.find_opt sym env.datatypes with | Some info -> return info - | None -> fail TypeErrors.{ loc; msg = TypeErrors.Unknown_datatype sym } + | None -> fail { loc; msg = Global (Unknown_datatype sym) } let lookup_constr loc sym env = match Sym.Map.find_opt sym env.datatype_constrs with | Some info -> return info - | None -> fail TypeErrors.{ loc; msg = TypeErrors.Unknown_datatype_constr sym } + | None -> fail { loc; msg = Global (Unknown_datatype_constr sym) } let cannot_tell_pointee_ctype loc e = @@ -852,7 +852,9 @@ module EffectfulTranslation = struct | Some fsig -> return fsig.return_bty | None -> fail - { loc; msg = Unknown_logical_function { id = fsym; resource = false } } + { loc; + msg = Global (Unknown_logical_function { id = fsym; resource = false }) + } in return (apply_ fsym args (BaseTypes.Surface.inj bt) loc)) | CNExpr_cons (c_nm, exprs) -> @@ -1070,7 +1072,10 @@ module EffectfulTranslation = struct let@ pred_sig = match lookup_predicate pred env with | None -> - fail { loc; msg = Unknown_resource_predicate { id = pred; logical = false } } + fail + { loc; + msg = Global (Unknown_resource_predicate { id = pred; logical = false }) + } | Some pred_sig -> return pred_sig in let output_bt = pred_sig.pred_output in diff --git a/backend/cn/lib/global.ml b/backend/cn/lib/global.ml index 85975a877..386f217b6 100644 --- a/backend/cn/lib/global.ml +++ b/backend/cn/lib/global.ml @@ -44,63 +44,89 @@ let sym_map_from_bindings xs = List.fold_left (fun m (nm, x) -> Sym.Map.add nm x m) Sym.Map.empty xs -module type Reader = sig - type global = t - +type error = + | Unknown_function of Sym.t + | Unknown_struct of Sym.t + | Unknown_datatype of Sym.t + | Unknown_datatype_constr of Sym.t + | Unknown_resource_predicate of + { id : Sym.t; + logical : bool + } + | Unknown_logical_function of + { id : Sym.t; + resource : bool + } + | Unknown_lemma of Sym.t + +type global_t_alias_do_not_use = t + +module type ErrorReader = sig type 'a t val return : 'a -> 'a t val bind : 'a t -> ('a -> 'b t) -> 'b t - type state - - val get : unit -> state t + val get_global : unit -> global_t_alias_do_not_use t - val to_global : state -> global + val fail : Locations.t -> error -> 'a t end module type Lifted = sig type 'a t - val get_resource_predicate_def : Sym.t -> Definition.Predicate.t option t + val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t t - val get_logical_function_def : Sym.t -> Definition.Function.t option t + val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t t val get_fun_decl - : Sym.t -> - (Cerb_location.t * AT.ft option * Sctypes.c_concrete_sig) option t + : Locations.t -> + Sym.t -> + (Cerb_location.t * AT.ft option * Sctypes.c_concrete_sig) t - val get_lemma : Sym.t -> (Cerb_location.t * AT.lemmat) option t + val get_lemma : Locations.t -> Sym.t -> (Cerb_location.t * AT.lemmat) t - val get_struct_decl : Sym.t -> Memory.struct_layout option t + val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_layout t - val get_datatype : Sym.t -> BaseTypes.dt_info option t + val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info t - val get_datatype_constr : Sym.t -> BaseTypes.constr_info option t + val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info t end -module Lift (M : Reader) : Lifted with type 'a t := 'a M.t = struct - let lift f sym = +module Lift (M : ErrorReader) : Lifted with type 'a t := 'a M.t = struct + let lift f loc sym msg = let ( let@ ) = M.bind in - let@ state = M.get () in - let global = M.to_global state in - M.return (f global sym) + let@ global = M.get_global () in + match f global sym with Some x -> M.return x | None -> M.fail loc (msg global) + + + let get_logical_function_def_opt id = get_logical_function_def id + + let get_logical_function_def loc id = + lift get_logical_function_def loc id (fun global -> + let res = get_resource_predicate_def global id in + Unknown_logical_function { id; resource = Option.is_some res }) + + let get_resource_predicate_def loc id = + lift get_resource_predicate_def loc id (fun global -> + let log = get_logical_function_def_opt global id in + Unknown_resource_predicate { id; logical = Option.is_some log }) - let get_resource_predicate_def = lift get_resource_predicate_def - let get_logical_function_def = lift get_logical_function_def + let get_fun_decl loc fsym = lift get_fun_decl loc fsym (fun _ -> Unknown_function fsym) - let get_fun_decl = lift get_fun_decl + let get_lemma loc lsym = lift get_lemma loc lsym (fun _ -> Unknown_lemma lsym) - let get_lemma = lift get_lemma + let get_struct_decl loc tag = lift get_struct_decl loc tag (fun _ -> Unknown_struct tag) - let get_struct_decl = lift get_struct_decl + let get_datatype loc tag = + lift get_datatype loc tag (fun _ -> Unknown_datatype_constr tag) - let get_datatype = lift get_datatype - let get_datatype_constr = lift get_datatype_constr + let get_datatype_constr loc tag = + lift get_datatype_constr loc tag (fun _ -> Unknown_datatype_constr tag) end let pp_struct_layout (tag, layout) = diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index bcaac62f2..e423b25a0 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -112,21 +112,9 @@ module RequestChain = struct end type message = - | Unknown_variable of Sym.t - | Unknown_function of Sym.t - | Unknown_struct of Sym.t - | Unknown_datatype of Sym.t - | Unknown_datatype_constr of Sym.t - | Unknown_resource_predicate of - { id : Sym.t; - logical : bool - } - | Unknown_logical_function of - { id : Sym.t; - resource : bool - } + | Global of Global.error | Unexpected_member of Id.t list * Id.t - | Unknown_lemma of Sym.t + | Unknown_variable of Sym.t (* some from Kayvan's compilePredicates module *) | First_iarg_missing | First_iarg_not_pointer of @@ -272,19 +260,19 @@ let pp_message te = | Unknown_variable s -> let short = !^"Unknown variable" ^^^ squotes (Sym.pp s) in { short; descr = None; state = None } - | Unknown_function sym -> + | Global (Unknown_function sym) -> let short = !^"Unknown function" ^^^ squotes (Sym.pp sym) in { short; descr = None; state = None } - | Unknown_struct tag -> + | Global (Unknown_struct tag) -> let short = !^"Struct" ^^^ squotes (Sym.pp tag) ^^^ !^"not defined" in { short; descr = None; state = None } - | Unknown_datatype tag -> + | Global (Unknown_datatype tag) -> let short = !^"Datatype" ^^^ squotes (Sym.pp tag) ^^^ !^"not defined" in { short; descr = None; state = None } - | Unknown_datatype_constr tag -> + | Global (Unknown_datatype_constr tag) -> let short = !^"Datatype constructor" ^^^ squotes (Sym.pp tag) ^^^ !^"not defined" in { short; descr = None; state = None } - | Unknown_resource_predicate { id; logical } -> + | Global (Unknown_resource_predicate { id; logical }) -> let short = !^"Unknown resource predicate" ^^^ squotes (Sym.pp id) in let descr = if logical then @@ -293,7 +281,7 @@ let pp_message te = None in { short; descr; state = None } - | Unknown_logical_function { id; resource } -> + | Global (Unknown_logical_function { id; resource }) -> let short = !^"Unknown logical function" ^^^ squotes (Sym.pp id) in let descr = if resource then @@ -302,13 +290,13 @@ let pp_message te = None in { short; descr; state = None } + | Global (Unknown_lemma sym) -> + let short = !^"Unknown lemma" ^^^ squotes (Sym.pp sym) in + { short; descr = None; state = None } | Unexpected_member (expected, member) -> let short = !^"Unexpected member" ^^^ Id.pp member in let descr = !^"the struct only has members" ^^^ list Id.pp expected in { short; descr = Some descr; state = None } - | Unknown_lemma sym -> - let short = !^"Unknown lemma" ^^^ squotes (Sym.pp sym) in - { short; descr = None; state = None } | First_iarg_missing -> let short = !^"Missing pointer input argument" in let descr = !^"a predicate definition must have at least one input argument" in diff --git a/backend/cn/lib/typeErrors.mli b/backend/cn/lib/typeErrors.mli index a5c1b9a3e..ae3f2fc64 100644 --- a/backend/cn/lib/typeErrors.mli +++ b/backend/cn/lib/typeErrors.mli @@ -50,21 +50,9 @@ module RequestChain : sig end type message = - | Unknown_variable of Sym.t - | Unknown_function of Sym.t - | Unknown_struct of Sym.t - | Unknown_datatype of Sym.t - | Unknown_datatype_constr of Sym.t - | Unknown_resource_predicate of - { id : Sym.t; - logical : bool - } - | Unknown_logical_function of - { id : Sym.t; - resource : bool - } + | Global of Global.error | Unexpected_member of Id.t list * Id.t - | Unknown_lemma of Sym.t + | Unknown_variable of Sym.t | First_iarg_missing | First_iarg_not_pointer of { pname : Request.name; diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index a0334fa9c..9019a3777 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -210,15 +210,17 @@ module ErrorReader = struct let bind = bind - type state = s + let get_global () = + let@ s = get () in + return s.typing_context.global - type global = Global.t - let get = get + let fail loc msg = fail (fun _ -> { loc; msg = Global msg }) - let to_global (s : s) = s.typing_context.global + let get_context () = + let@ s = get () in + return s.typing_context - let to_context (s : s) = s.typing_context let lift = lift end @@ -230,63 +232,12 @@ module Global = struct let is_fun_decl global id = Option.is_some @@ Global.get_fun_decl global id - let get_logical_function_def_opt id = get_logical_function_def id - - let error_if_none opt loc msg = - let@ opt in - Option.fold - opt - ~some:return - ~none: - (let@ msg in - fail (fun _ -> { loc; msg })) - - - let get_logical_function_def loc id = - error_if_none - (get_logical_function_def id) - loc - (let@ res = get_resource_predicate_def id in - return (TypeErrors.Unknown_logical_function { id; resource = Option.is_some res })) - - - let get_struct_decl loc tag = - error_if_none (get_struct_decl tag) loc (return (TypeErrors.Unknown_struct tag)) - - - let get_datatype loc tag = - error_if_none (get_datatype tag) loc (return (TypeErrors.Unknown_datatype tag)) - - - let get_datatype_constr loc tag = - error_if_none - (get_datatype_constr tag) - loc - (return (TypeErrors.Unknown_datatype_constr tag)) - - let get_struct_member_type loc tag member = let@ decl = get_struct_decl loc tag in let@ ty = get_member_type loc member decl in return ty - let get_fun_decl loc fsym = - error_if_none (get_fun_decl fsym) loc (return (TypeErrors.Unknown_function fsym)) - - - let get_lemma loc lsym = - error_if_none (get_lemma lsym) loc (return (TypeErrors.Unknown_lemma lsym)) - - - let get_resource_predicate_def loc id = - error_if_none - (get_resource_predicate_def id) - loc - (let@ log = get_logical_function_def_opt id in - return (TypeErrors.Unknown_resource_predicate { id; logical = Option.is_some log })) - - let get_fun_decls () = let@ global = get_global () in return (Sym.Map.bindings global.fun_decls) diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index 14222bec2..bd6ef4246 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -18,33 +18,38 @@ module GlobalReader = struct let bind x f s = match x s with Ok (y, s') -> f y s' | Error err -> Error err - let get () s = Ok (s, s) + let get_global () s = Ok (s.Context.global, s) - let to_global ctxt = ctxt.Context.global - - type global = Global.t - - type state = Context.t + let fail loc msg _ = Error TypeErrors.{ loc; msg = Global msg } end module NoSolver = struct include GlobalReader include Global.Lift (GlobalReader) - type failure = TypeErrors.t + let fail err : 'a t = fun _ -> Error err - let liftFail typeErr = typeErr + let ( let@ ) = bind + + let get_member_type loc member layout : Sctypes.t t = + let member_types = Memory.member_types layout in + match List.assoc_opt Id.equal member member_types with + | Some membertyp -> return membertyp + | None -> fail { loc; msg = Unexpected_member (List.map fst member_types, member) } + + + let get_struct_member_type loc tag member = + let@ decl = get_struct_decl loc tag in + let@ ty = get_member_type loc member decl in + return ty - let pure x s = match x s with Ok (y, _) -> Ok (y, s) | Error err -> Error err - let fail (typeErr : failure) : 'a t = fun _ -> Error (liftFail typeErr) + let pure x s = match x s with Ok (y, _) -> Ok (y, s) | Error err -> Error err let update f s = Ok ((), f s) let lookup f : _ t = fun s -> Ok (f s, s) - let ( let@ ) = bind - let bound_a sym = lookup (Context.bound_a sym) let bound_l sym = lookup (Context.bound_l sym) @@ -64,70 +69,6 @@ module NoSolver = struct fail { loc; msg = Mismatch { has = BT.pp has; expect = BT.pp expect } } - let error_if_none opt loc msg = - let@ opt in - Option.fold - opt - ~some:return - ~none: - (let@ msg in - fail { loc; msg }) - - - let get_logical_function_def_opt id = get_logical_function_def id - - let get_logical_function_def loc id = - error_if_none - (get_logical_function_def id) - loc - (let@ res = get_resource_predicate_def id in - return (TypeErrors.Unknown_logical_function { id; resource = Option.is_some res })) - - - let get_struct_decl loc tag = - error_if_none (get_struct_decl tag) loc (return (TypeErrors.Unknown_struct tag)) - - - let get_datatype loc tag = - error_if_none (get_datatype tag) loc (return (TypeErrors.Unknown_datatype tag)) - - - let get_datatype_constr loc tag = - error_if_none - (get_datatype_constr tag) - loc - (return (TypeErrors.Unknown_datatype_constr tag)) - - - let get_member_type loc member layout : Sctypes.t t = - let member_types = Memory.member_types layout in - match List.assoc_opt Id.equal member member_types with - | Some membertyp -> return membertyp - | None -> fail { loc; msg = Unexpected_member (List.map fst member_types, member) } - - - let get_struct_member_type loc tag member = - let@ decl = get_struct_decl loc tag in - let@ ty = get_member_type loc member decl in - return ty - - - let get_fun_decl loc fsym = - error_if_none (get_fun_decl fsym) loc (return (TypeErrors.Unknown_function fsym)) - - - let get_lemma loc lsym = - error_if_none (get_lemma lsym) loc (return (TypeErrors.Unknown_lemma lsym)) - - - let get_resource_predicate_def loc id = - error_if_none - (get_resource_predicate_def id) - loc - (let@ log = get_logical_function_def_opt id in - return (TypeErrors.Unknown_resource_predicate { id; logical = Option.is_some log })) - - let lift = function Ok x -> return x | Error x -> fail x let run ctxt x = x ctxt @@ -137,8 +78,6 @@ let use_ity = ref true open NoSolver -let fail typeErr = fail (liftFail typeErr) - open Effectful.Make (NoSolver) let illtyped_index_term (loc : Locations.t) it has ~expected ~reason = @@ -2523,11 +2462,7 @@ module type ErrorReader = sig val bind : 'a t -> ('a -> 'b t) -> 'b t - type state - - val get : unit -> state t - - val to_context : state -> Context.t + val get_context : unit -> Context.t t val lift : 'a Or_TypeError.t -> 'a t end @@ -2535,22 +2470,19 @@ end module Lift (M : ErrorReader) : WellTyped_intf.S with type 'a t := 'a M.t = struct let lift1 f x = let ( let@ ) = M.bind in - let@ state = M.get () in - let context = M.to_context state in + let@ context = M.get_context () in M.lift (Result.map fst (run context (f x))) let lift2 f x y = let ( let@ ) = M.bind in - let@ state = M.get () in - let context = M.to_context state in + let@ context = M.get_context () in M.lift (Result.map fst (f x y context)) let lift3 f x y z = let ( let@ ) = M.bind in - let@ state = M.get () in - let context = M.to_context state in + let@ context = M.get_context () in M.lift (Result.map fst (f x y z context)) @@ -2594,8 +2526,7 @@ module Lift (M : ErrorReader) : WellTyped_intf.S with type 'a t := 'a M.t = stru let ensure_same_argument_number loc type_ n ~expect = let ( let@ ) = M.bind in - let@ state = M.get () in - let context = M.to_context state in + let@ context = M.get_context () in M.lift (Result.map fst (ensure_same_argument_number loc type_ n ~expect context)) diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index 762140161..22296b75e 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -9,11 +9,7 @@ module type ErrorReader = sig val bind : 'a t -> ('a -> 'b t) -> 'b t - type state - - val get : unit -> state t - - val to_context : state -> Context.t + val get_context : unit -> Context.t t val lift : 'a Or_TypeError.t -> 'a t end diff --git a/tests/cn/tree16/as_mutual_dt/tree16.c.verify b/tests/cn/tree16/as_mutual_dt/tree16.c.verify index 20653f7a8..37b1eeaf0 100644 --- a/tests/cn/tree16/as_mutual_dt/tree16.c.verify +++ b/tests/cn/tree16/as_mutual_dt/tree16.c.verify @@ -8,8 +8,8 @@ tests/cn/tree16/as_mutual_dt/tree16.c:111:19: warning: 'each' expects a 'u64', b tests/cn/tree16/as_mutual_dt/tree16.c:121:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) ^ -other location (File "backend/cn/lib/compile.ml", line 1571, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1576, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. -other location (File "backend/cn/lib/compile.ml", line 1571, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1576, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. [1/1]: lookup_rec -- pass diff --git a/tests/cn/tree16/as_partial_map/tree16.c.verify b/tests/cn/tree16/as_partial_map/tree16.c.verify index 01ac506e8..0132fc840 100644 --- a/tests/cn/tree16/as_partial_map/tree16.c.verify +++ b/tests/cn/tree16/as_partial_map/tree16.c.verify @@ -14,9 +14,9 @@ tests/cn/tree16/as_partial_map/tree16.c:137:19: warning: 'each' expects a 'u64', tests/cn/tree16/as_partial_map/tree16.c:146:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) ^ -other location (File "backend/cn/lib/compile.ml", line 1571, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1576, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. -other location (File "backend/cn/lib/compile.ml", line 1571, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1576, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. [1/2]: cn_get_num_nodes -- pass [2/2]: lookup_rec -- pass From 3fea76a95404dc795229762db1da4ee49019bd7c Mon Sep 17 00:00:00 2001 From: Dhruv Makwana Date: Sun, 29 Dec 2024 23:27:49 +0000 Subject: [PATCH 144/148] CN: Factor out WellTyped error messages This commit also removes some duplication for ensure_base_type; but this raises another question - why are there _any_ base type checks in check.ml? Surely they are all redundant and signal an error in WellTyped.ml? As it turns out, integer promotions are not handled correctly... #272 ```c int main() { int size1 = sizeof(int); // <- works size1 = size1 + 1; // <- also works int size2 = sizeof(int) + 1; // <- fails } ``` --- backend/cn/lib/builtins.ml | 19 +- backend/cn/lib/cLogicalFuns.ml | 13 +- backend/cn/lib/check.ml | 348 +++++++++++------- backend/cn/lib/compile.ml | 65 ++-- backend/cn/lib/coreTypeChecks.ml | 28 +- backend/cn/lib/core_to_mucore.ml | 5 +- backend/cn/lib/diagnostics.ml | 5 +- backend/cn/lib/global.ml | 10 + backend/cn/lib/typeErrors.ml | 218 ++++------- backend/cn/lib/typeErrors.mli | 38 +- backend/cn/lib/typing.ml | 40 +- backend/cn/lib/typing.mli | 4 +- backend/cn/lib/wellTyped.ml | 135 ++++--- backend/cn/lib/wellTyped.mli | 34 +- backend/cn/lib/wellTyped_intf.ml | 6 +- tests/cn/tree16/as_mutual_dt/tree16.c.verify | 4 +- .../cn/tree16/as_partial_map/tree16.c.verify | 4 +- 17 files changed, 520 insertions(+), 456 deletions(-) diff --git a/backend/cn/lib/builtins.ml b/backend/cn/lib/builtins.ml index 0ccf6ca3e..2d826a69d 100644 --- a/backend/cn/lib/builtins.ml +++ b/backend/cn/lib/builtins.ml @@ -2,24 +2,27 @@ module SBT = BaseTypes.Surface open Or_TypeError open IndexTerms +let fail_number_args loc ~has ~expect = + fail { loc; msg = WellTyped (Number_arguments { type_ = `Other; has; expect }) } + + (* builtin function symbols *) let mk_arg0 mk args loc = match args with | [] -> return (mk loc) - | _ :: _ as xs -> - fail { loc; msg = Number_arguments { has = List.length xs; expect = 0 } } + | _ :: _ as xs -> fail_number_args loc ~has:(List.length xs) ~expect:0 let mk_arg1 mk args loc = match args with | [ x ] -> return (mk x loc) - | xs -> fail { loc; msg = Number_arguments { has = List.length xs; expect = 1 } } + | xs -> fail_number_args loc ~has:(List.length xs) ~expect:1 let mk_arg2_err mk args loc = match args with | [ x; y ] -> mk (x, y) loc - | xs -> fail { loc; msg = Number_arguments { has = List.length xs; expect = 2 } } + | xs -> fail_number_args loc ~has:(List.length xs) ~expect:2 let mk_arg2 mk = mk_arg2_err (fun tup loc -> return (mk tup loc)) @@ -27,7 +30,7 @@ let mk_arg2 mk = mk_arg2_err (fun tup loc -> return (mk tup loc)) let mk_arg3_err mk args loc = match args with | [ x; y; z ] -> mk (x, y, z) loc - | xs -> fail { loc; msg = Number_arguments { has = List.length xs; expect = 3 } } + | xs -> fail_number_args loc ~has:(List.length xs) ~expect:3 let mk_arg3 mk = mk_arg3_err (fun tup loc -> return (mk tup loc)) @@ -35,7 +38,7 @@ let mk_arg3 mk = mk_arg3_err (fun tup loc -> return (mk tup loc)) let mk_arg5 mk args loc = match args with | [ a; b; c; d; e ] -> return (mk (a, b, c, d, e) loc) - | xs -> fail { loc; msg = Number_arguments { has = List.length xs; expect = 5 } } + | xs -> fail_number_args loc ~has:(List.length xs) ~expect:5 let min_bits_def (sign, n) = @@ -124,7 +127,9 @@ let array_to_list_def = let expected = "map/array" in fail { loc; - msg = Illtyped_it { it = pp arr; has = SBT.pp (get_bt arr); expected; reason } + msg = + WellTyped + (Illtyped_it { it = pp arr; has = SBT.pp (get_bt arr); expected; reason }) } | Some (_, bt) -> return (array_to_list_ (arr, i, len) bt loc)) ) diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index a97eac804..6769ff8b3 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -1,15 +1,14 @@ -open TypeErrors -open Typing - -open Effectful.Make (Typing) - module StringMap = Map.Make (String) module IntMap = Map.Make (Int) module CF = Cerb_frontend module BT = BaseTypes -open Cerb_pp_prelude module Mu = Mucore module IT = IndexTerms +open Cerb_pp_prelude +open TypeErrors +open Typing + +open Effectful.Make (Typing) let fail_n m = fail (fun _ctxt -> m) @@ -245,7 +244,7 @@ let rec symb_exec_pexpr ctxt var_map pexpr = | PEsym sym -> (match Sym.Map.find_opt sym var_map with | Some r -> return r - | _ -> fail_n { loc; msg = Unknown_variable sym }) + | _ -> fail_n { loc; msg = WellTyped (Unknown_variable sym) }) | PEval v -> (match val_to_it loc v with | Some r -> return r diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index 8fdb6ffd1..bfa0383c9 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -42,13 +42,16 @@ let rec check_and_match_pattern (Mu.Pattern (loc, _, bty, pattern)) it = match bty with | BT.List item_bt -> return item_bt | _ -> - fail (fun _ -> { loc; msg = Mismatch { has = !^"list"; expect = BT.pp bty } }) + fail (fun _ -> + { loc; msg = WellTyped (Mismatch { has = !^"list"; expect = BT.pp bty }) }) in let@ () = add_c loc (LC.T (eq__ it (nil_ ~item_bt loc) loc)) in return [] | Ccons, [ p1; p2 ] -> - let@ () = ensure_base_type loc ~expect:bty (List (Mu.bt_of_pattern p1)) in - let@ () = ensure_base_type loc ~expect:bty (Mu.bt_of_pattern p2) in + let@ () = + WellTyped.ensure_base_type loc ~expect:bty (List (Mu.bt_of_pattern p1)) + in + let@ () = WellTyped.ensure_base_type loc ~expect:bty (Mu.bt_of_pattern p2) in let item_bt = Mu.bt_of_pattern p1 in let@ a1 = check_and_match_pattern p1 (head_ ~item_bt it loc) in let@ a2 = check_and_match_pattern p2 (tail_ it loc) in @@ -56,7 +59,10 @@ let rec check_and_match_pattern (Mu.Pattern (loc, _, bty, pattern)) it = return (a1 @ a2) | Ctuple, pats -> let@ () = - ensure_base_type loc ~expect:bty (Tuple (List.map Mu.bt_of_pattern pats)) + WellTyped.ensure_base_type + loc + ~expect:bty + (Tuple (List.map Mu.bt_of_pattern pats)) in let@ all_as = ListM.mapiM @@ -77,7 +83,7 @@ let check_computational_bound loc s = if is_bound then return () else - fail (fun _ -> { loc; msg = Unknown_variable s }) + fail (fun _ -> { loc; msg = WellTyped (Unknown_variable s) }) let unsupported loc doc = @@ -85,7 +91,7 @@ let unsupported loc doc = let check_ptrval (loc : Locations.t) ~(expect : BT.t) (ptrval : pointer_value) : IT.t m = - let@ () = ensure_base_type loc ~expect BT.(Loc ()) in + let@ () = WellTyped.ensure_base_type loc ~expect BT.(Loc ()) in CF.Impl_mem.case_ptrval ptrval (fun ct -> @@ -116,7 +122,7 @@ let expect_must_be_map_bt loc ~expect = match expect with | BT.Map (index_bt, item_bt) -> return (index_bt, item_bt) | _ -> - let msg = Mismatch { has = !^"array"; expect = BT.pp expect } in + let msg = WellTyped (Mismatch { has = !^"array"; expect = BT.pp expect }) in fail (fun _ -> { loc; msg }) @@ -130,7 +136,7 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : (fun ity iv -> let@ () = WellTyped.check_ct loc (Integer ity) in let bt = Memory.bt_of_sct (Integer ity) in - let@ () = ensure_base_type loc ~expect bt in + let@ () = WellTyped.ensure_base_type loc ~expect bt in return (int_lit_ (Memory.int_of_ival iv) bt loc)) (fun _ft _fv -> unsupported loc !^"floats") (fun ct ptrval -> @@ -144,7 +150,7 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : return (make_array_ ~index_bt ~item_bt values loc)) (fun tag mvals -> let@ () = WellTyped.check_ct loc (Struct tag) in - let@ () = ensure_base_type loc ~expect (Struct tag) in + let@ () = WellTyped.ensure_base_type loc ~expect (Struct tag) in let mvals = List.map (fun (id, ct, mv) -> (id, Sctypes.of_ctype_unsafe loc ct, mv)) mvals in @@ -187,7 +193,9 @@ let ensure_bitvector_type (loc : Locations.t) ~(expect : BT.t) : (BT.sign * int) | None -> fail (fun _ -> { loc; - msg = Mismatch { has = !^"(unspecified) bitvector type"; expect = BT.pp expect } + msg = + WellTyped + (Mismatch { has = !^"(unspecified) bitvector type"; expect = BT.pp expect }) }) @@ -214,13 +222,14 @@ let rec check_object_value (loc : Locations.t) (Mu.OV (expect, ov)) : IT.t m = assert (Option.is_some (BT.is_bits_bt index_bt)); let@ () = ListM.iterM - (fun i -> ensure_base_type loc ~expect:item_bt (Mu.bt_of_object_value i)) + (fun i -> + WellTyped.ensure_base_type loc ~expect:item_bt (Mu.bt_of_object_value i)) items in let@ values = ListM.mapM (check_object_value loc) items in return (make_array_ ~index_bt ~item_bt values loc) | OVstruct (tag, fields) -> - let@ () = ensure_base_type loc ~expect (Struct tag) in + let@ () = WellTyped.ensure_base_type loc ~expect (Struct tag) in check_struct loc tag fields | OVunion (tag, id, mv) -> check_union loc tag id mv | OVfloating _iv -> unsupported loc !^"floats" @@ -229,38 +238,40 @@ let rec check_object_value (loc : Locations.t) (Mu.OV (expect, ov)) : IT.t m = let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = match v with | Vobject ov -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_object_value ov) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_object_value ov) in check_object_value loc ov | Vctype ct -> - let@ () = ensure_base_type loc ~expect CType in + let@ () = WellTyped.ensure_base_type loc ~expect CType in let ct = Sctypes.of_ctype_unsafe loc ct in let@ () = WellTyped.check_ct loc ct in return (IT.const_ctype_ ct loc) | Vunit -> - let@ () = ensure_base_type loc ~expect Unit in + let@ () = WellTyped.ensure_base_type loc ~expect Unit in return (IT.unit_ loc) | Vtrue -> - let@ () = ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in return (IT.bool_ true loc) | Vfalse -> - let@ () = ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in return (IT.bool_ false loc) | Vfunction_addr sym -> - let@ () = ensure_base_type loc ~expect (Loc ()) in + let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in (* check it is a valid function address *) let@ _ = Global.get_fun_decl loc sym in return (IT.sym_ (sym, BT.(Loc ()), loc)) | Vlist (_item_cbt, vals) -> let item_bt = Mu.bt_of_value (List.hd vals) in - let@ () = ensure_base_type loc ~expect (List item_bt) in + let@ () = WellTyped.ensure_base_type loc ~expect (List item_bt) in let@ () = - ListM.iterM (fun i -> ensure_base_type loc ~expect:item_bt (Mu.bt_of_value i)) vals + ListM.iterM + (fun i -> WellTyped.ensure_base_type loc ~expect:item_bt (Mu.bt_of_value i)) + vals in let@ values = ListM.mapM (check_value loc) vals in return (list_ ~item_bt values ~nil_loc:loc) | Vtuple vals -> let item_bts = List.map Mu.bt_of_value vals in - let@ () = ensure_base_type loc ~expect (Tuple item_bts) in + let@ () = WellTyped.ensure_base_type loc ~expect (Tuple item_bts) in let@ values = ListM.mapM (check_value loc) vals in return (tuple_ values loc) @@ -412,11 +423,9 @@ let check_conv_int loc ~expect ct arg = let check_against_core_bt loc msg2 cbt bt = - Typing.lift - (CoreTypeChecks.check_against_core_bt - (fun msg -> Or_TypeError.fail { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) - cbt - bt) + CoreTypeChecks.check_against_core_bt cbt bt + |> Result.map_error (fun msg -> { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) + |> Typing.lift let check_has_alloc_id loc ptr ub_unspec = @@ -511,27 +520,29 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ binding = get_a sym in (match binding with | BaseType bt -> - let@ () = ensure_base_type loc ~expect bt in + let@ () = WellTyped.ensure_base_type loc ~expect bt in k (sym_ (sym, bt, loc)) | Value lvt -> - let@ () = ensure_base_type loc ~expect (IT.get_bt lvt) in + let@ () = WellTyped.ensure_base_type loc ~expect (IT.get_bt lvt) in k lvt) | PEval v -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_value v) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_value v) in let@ vt = check_value loc v in k vt | PEconstrained _ -> Cerb_debug.error "todo: PEconstrained" | PEctor (ctor, pes) -> (match (ctor, pes) with | Ctuple, _ -> - let@ () = ensure_base_type loc ~expect (Tuple (List.map Mu.bt_of_pexpr pes)) in + let@ () = + WellTyped.ensure_base_type loc ~expect (Tuple (List.map Mu.bt_of_pexpr pes)) + in check_pexprs pes (fun values -> k (tuple_ values loc)) | Carray, _ -> let@ index_bt, item_bt = expect_must_be_map_bt loc ~expect in assert (Option.is_some (BT.is_bits_bt index_bt)); let@ () = ListM.iterM - (fun i -> ensure_base_type loc ~expect:item_bt (Mu.bt_of_pexpr i)) + (fun i -> WellTyped.ensure_base_type loc ~expect:item_bt (Mu.bt_of_pexpr i)) pes in check_pexprs pes (fun values -> k (make_array_ ~index_bt ~item_bt values loc)) @@ -540,25 +551,33 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = match expect with | List item_bt -> return item_bt | _ -> - let msg = Mismatch { has = !^"list"; expect = BT.pp expect } in + let msg = WellTyped (Mismatch { has = !^"list"; expect = BT.pp expect }) in fail (fun _ -> { loc; msg }) in let@ () = check_against_core_bt loc !^"checking Cnil" item_cbt item_bt in k (nil_ ~item_bt loc) | Cnil _item_bt, _ -> fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pes; expect = 0 } }) + { loc; + msg = + WellTyped + (Number_arguments { type_ = `Other; has = List.length pes; expect = 0 }) + }) | Ccons, [ pe1; pe2 ] -> - let@ () = ensure_base_type loc ~expect (List (Mu.bt_of_pexpr pe1)) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_base_type loc ~expect (List (Mu.bt_of_pexpr pe1)) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> k (cons_ (vt1, vt2) loc))) | Ccons, _ -> fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pes; expect = 2 } })) + { loc; + msg = + WellTyped + (Number_arguments { type_ = `Other; has = List.length pes; expect = 2 }) + })) | PEbitwise_unop (unop, pe1) -> let@ _ = ensure_bitvector_type loc ~expect in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in check_pexpr pe1 (fun vt1 -> let unop = match unop with @@ -570,8 +589,8 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = k value) | PEbitwise_binop (binop, pe1, pe2) -> let@ _ = ensure_bitvector_type loc ~expect in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in let binop = match binop with BW_AND -> BW_And | BW_OR -> BW_Or | BW_XOR -> BW_Xor in @@ -582,9 +601,9 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | Cfvfromint _ -> unsupported loc !^"floats" | Civfromfloat _ -> unsupported loc !^"floats" | PEarray_shift (pe1, ct, pe2) -> - let@ () = ensure_base_type loc ~expect (Loc ()) in + let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in let@ () = WellTyped.check_ct loc ct in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> @@ -608,8 +627,8 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in k result)) | PEmember_shift (pe, tag, member) -> - let@ () = ensure_base_type loc ~expect (Loc ()) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun vt -> let@ ct = Global.get_struct_member_type loc tag member in let result = memberShift_ (vt, tag, member) loc in @@ -627,15 +646,17 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in k result) | PEnot pe -> - let@ () = ensure_base_type loc ~expect Bool in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in check_pexpr pe (fun vt -> k (not_ vt loc)) | PEop (op, pe1, pe2) -> let check_cmp_ty = function | BT.Integer | Bits _ | Real -> return () | ty -> fail (fun _ -> - { loc; msg = Mismatch { has = BT.pp ty; expect = !^"comparable type" } }) + { loc; + msg = WellTyped (Mismatch { has = BT.pp ty; expect = !^"comparable type" }) + }) in let not_yet x = Pp.debug 1 (lazy (Pp.item "not yet restored" (Pp_mucore_ast.pp_pexpr orig_pe))); @@ -643,7 +664,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in (match op with | OpDiv -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc expect in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> @@ -658,7 +679,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let ub = CF.Undefined.UB045a_division_by_zero in fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } }))) | OpRem_t -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc expect in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> @@ -673,48 +694,63 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let ub = CF.Undefined.UB045b_modulo_by_zero in fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } }))) | OpEq -> - let@ () = ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = - ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) + WellTyped.ensure_base_type + loc + ~expect:(Mu.bt_of_pexpr pe1) + (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (eq_ (v1, v2) loc))) | OpGt -> - let@ () = ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = check_cmp_ty (Mu.bt_of_pexpr pe1) in let@ () = - ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) + WellTyped.ensure_base_type + loc + ~expect:(Mu.bt_of_pexpr pe1) + (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (gt_ (v1, v2) loc))) | OpLt -> - let@ () = ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = check_cmp_ty (Mu.bt_of_pexpr pe1) in let@ () = - ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) + WellTyped.ensure_base_type + loc + ~expect:(Mu.bt_of_pexpr pe1) + (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (lt_ (v1, v2) loc))) | OpGe -> - let@ () = ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = check_cmp_ty (Mu.bt_of_pexpr pe1) in let@ () = - ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) + WellTyped.ensure_base_type + loc + ~expect:(Mu.bt_of_pexpr pe1) + (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (ge_ (v1, v2) loc))) | OpLe -> - let@ () = ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = check_cmp_ty (Mu.bt_of_pexpr pe1) in let@ () = - ensure_base_type loc ~expect:(Mu.bt_of_pexpr pe1) (Mu.bt_of_pexpr pe2) + WellTyped.ensure_base_type + loc + ~expect:(Mu.bt_of_pexpr pe1) + (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (le_ (v1, v2) loc))) | OpAnd -> - let@ () = ensure_base_type loc ~expect Bool in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe1) in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (and_ [ v1; v2 ] loc))) | OpOr -> - let@ () = ensure_base_type loc ~expect Bool in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe1) in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun v1 -> check_pexpr pe2 (fun v2 -> k (or_ [ v1; v2 ] loc))) | OpAdd -> not_yet "OpAdd" | OpSub -> @@ -728,7 +764,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | PEapply_fun (fun_id, args) -> let@ () = match Mu.fun_return_type fun_id args with - | Some (`Returns_BT bt) -> ensure_base_type loc ~expect bt + | Some (`Returns_BT bt) -> WellTyped.ensure_base_type loc ~expect bt | Some `Returns_Integer -> WellTyped.ensure_bits_type loc expect | None -> fail (fun _ -> @@ -742,14 +778,11 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ () = let has = List.length args in let expect = List.length expect_args in - if expect = has then - return () - else - fail (fun _ -> { loc; msg = Number_arguments { has; expect } }) + WellTyped.ensure_same_argument_number loc `Other has ~expect in let@ _ = ListM.map2M - (fun pe expect -> ensure_base_type loc ~expect (Mu.bt_of_pexpr pe)) + (fun pe expect -> WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe)) args expect_args in @@ -758,14 +791,17 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = k res) | PEstruct (tag, xs) -> let@ () = WellTyped.check_ct loc (Struct tag) in - let@ () = ensure_base_type loc ~expect (Struct tag) in + let@ () = WellTyped.ensure_base_type loc ~expect (Struct tag) in let@ layout = Global.get_struct_decl loc tag in let member_types = Memory.member_types layout in let@ _ = ListM.map2M (fun (id, ct) (id', pe') -> assert (Id.equal id id'); - ensure_base_type loc ~expect:(Memory.bt_of_sct ct) (Mu.bt_of_pexpr pe')) + WellTyped.ensure_base_type + loc + ~expect:(Memory.bt_of_sct ct) + (Mu.bt_of_pexpr pe')) member_types xs in @@ -774,8 +810,10 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = k (struct_ (tag, members) loc)) | PEunion _ -> Cerb_debug.error "todo: PEunion" | PEcfunction pe2 -> - let@ () = ensure_base_type loc ~expect (Tuple [ CType; List CType; Bool; Bool ]) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in + let@ () = + WellTyped.ensure_base_type loc ~expect (Tuple [ CType; List CType; Bool; Bool ]) + in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in check_pexpr pe2 (fun ptr -> let@ _global = get_global () in (* function vals are just symbols the same as the names of functions *) @@ -790,7 +828,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | PEmemberof _ -> Cerb_debug.error "todo: PEmemberof" | PEbool_to_integer pe -> let@ _ = ensure_bitvector_type loc ~expect in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> k (ite_ (arg, int_lit_ 1 expect loc, int_lit_ 0 expect loc) loc)) | PEbounded_binop (Bound_Wrap act, iop, pe1, pe2) -> @@ -801,14 +839,14 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = match act.ct with | Integer ity when Sctypes.is_unsigned_integer_type ity -> true | _ -> false); - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc expect in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in let@ () = match iop with | IOpShl | IOpShr -> return () - | _ -> ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) + | _ -> WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> @@ -843,14 +881,14 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | PEbounded_binop (Bound_Except act, iop, pe1, pe2) -> let@ () = WellTyped.check_ct act.loc act.ct in let ity = match act.ct with Integer ity -> ity | _ -> assert false in - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc expect in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in let@ () = match iop with | IOpShl | IOpShr -> return () - | _ -> ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) + | _ -> WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in let _, bits = Option.get (BT.is_bits_bt expect) in check_pexpr pe1 (fun arg1 -> @@ -889,12 +927,12 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in k direct_x)) | PEconv_int (ct_expr, pe) | PEconv_loaded_int (ct_expr, pe) -> - let@ () = ensure_base_type loc ~expect:CType (Mu.bt_of_pexpr ct_expr) in + let@ () = WellTyped.ensure_base_type loc ~expect:CType (Mu.bt_of_pexpr ct_expr) in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr ct_expr (fun ct_it -> let@ ct = check_single_ct loc ct_it in let@ () = WellTyped.check_ct loc ct in - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct ct) in + let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct ct) in check_pexpr pe (fun lvt -> let@ vt = check_conv_int loc ~expect ct lvt in k vt)) @@ -921,14 +959,14 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } })) | PEis_representable_integer (pe, act) -> let@ () = WellTyped.check_ct act.loc act.ct in - let@ () = ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in let ity = Option.get (Sctypes.is_integer_type act.ct) in check_pexpr pe (fun arg -> k (is_representable_integer arg ity)) | PEif (pe, e1, e2) -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr e1) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr e2) in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr e1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr e2) in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in check_pexpr pe (fun c -> let aux e cond name = let@ () = add_c loc (LC.T cond) in @@ -950,8 +988,10 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ () = pure (aux e2 (not_ c here) "else") in return ()) | PElet (p, e1, e2) -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr e2) in - let@ () = ensure_base_type loc ~expect:(Mu.bt_of_pexpr e1) (Mu.bt_of_pattern p) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr e2) in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Mu.bt_of_pexpr e1) (Mu.bt_of_pattern p) + in check_pexpr e1 (fun v1 -> let@ bound_a = check_and_match_pattern p v1 in check_pexpr e2 (fun lvt -> @@ -1064,7 +1104,7 @@ end = struct | _ -> let expect = count_computational original_ftyp in let has = List.length original_args in - fail (fun _ -> { loc; msg = Number_arguments { expect; has } }) + WellTyped.ensure_same_argument_number loc `Other has ~expect in fun args ftyp k -> aux [] args ftyp k in @@ -1072,7 +1112,9 @@ end = struct let check_arg_pexpr (pe : BT.t Mu.pexpr) ~expect k = - let@ () = ensure_base_type (Mu.loc_of_pexpr pe) ~expect (Mu.bt_of_pexpr pe) in + let@ () = + WellTyped.ensure_base_type (Mu.loc_of_pexpr pe) ~expect (Mu.bt_of_pexpr pe) + in check_pexpr pe k @@ -1318,12 +1360,12 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in (match e_ with | Epure pe -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe) in check_pexpr pe (fun lvt -> k lvt) | Ememop memop -> let here = Locations.other __LOC__ in let pointer_eq ?(negate = false) pe1 pe2 = - let@ () = ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in let k, case, res = if negate then ((fun x -> k (not_ x loc)), "in", "ptrNeq") else (k, "", "ptrEq") in @@ -1394,9 +1436,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in let pointer_op op pe1 pe2 = let ub = CF.Undefined.UB053_distinct_aggregate_union_pointer_comparison in - let@ () = ensure_base_type loc ~expect Bool in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> let@ () = check_both_eq_alloc loc arg1 arg2 ub in @@ -1412,9 +1454,15 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrGe (pe1, pe2) -> pointer_op (Fun.flip gePointer_ loc) pe1 pe2 | Ptrdiff (act, pe1, pe2) -> let@ () = WellTyped.check_ct act.loc act.ct in - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct (Integer Ptrdiff_t)) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in + let@ () = + WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct (Integer Ptrdiff_t)) + in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) + in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) + in check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> (* copying and adapting from memory/concrete/impl_mem.ml *) @@ -1443,8 +1491,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = WellTyped.check_ct act_from.loc act_from.ct in let@ () = WellTyped.check_ct act_to.loc act_to.ct in assert (match act_to.ct with Integer _ -> true | _ -> false); - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act_to.ct) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct act_to.ct) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let actual_value = cast_ (Memory.bt_of_sct act_to.ct) arg loc in (* NOTE: After discussing with Kavyan @@ -1469,9 +1517,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrFromInt (act_from, act_to, pe) -> let@ () = WellTyped.check_ct act_from.loc act_from.ct in let@ () = WellTyped.check_ct act_to.loc act_to.ct in - let@ () = ensure_base_type loc ~expect (Loc ()) in + let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in let@ () = - ensure_base_type + WellTyped.ensure_base_type loc ~expect:(Memory.bt_of_sct act_from.ct) (Mu.bt_of_pexpr pe) @@ -1496,8 +1544,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrValidForDeref (act, pe) -> (* TODO (DCM, VIP) *) let@ () = WellTyped.check_ct act.loc act.ct in - let@ () = ensure_base_type loc ~expect Bool in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in (* TODO (DCM, VIP): error if called on Void or Function Ctype. return false if resource missing *) check_pexpr pe (fun arg -> @@ -1511,8 +1559,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k result) | PtrWellAligned (act, pe) -> let@ () = WellTyped.check_ct act.loc act.ct in - let@ () = ensure_base_type loc ~expect Bool in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in (* TODO (DCM, VIP): error if called on Void or Function Ctype *) check_pexpr pe (fun arg -> (* let unspec = CF.Undefined.UB_unspec_pointer_add in *) @@ -1520,8 +1568,10 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let result = aligned_ (arg, act.ct) loc in k result) | PtrArrayShift (pe1, act, pe2) -> - let@ () = ensure_base_type loc ~expect (Loc ()) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) + in let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> @@ -1545,8 +1595,12 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (Loc.other __LOC__) !^"PtrMemberShift should be a CHERI only construct" | CopyAllocId (pe1, pe2) -> - let@ () = ensure_base_type loc ~expect:Memory.uintptr_bt (Mu.bt_of_pexpr pe1) in - let@ () = ensure_base_type loc ~expect:BT.(Loc ()) (Mu.bt_of_pexpr pe2) in + let@ () = + WellTyped.ensure_base_type loc ~expect:Memory.uintptr_bt (Mu.bt_of_pexpr pe1) + in + let@ () = + WellTyped.ensure_base_type loc ~expect:BT.(Loc ()) (Mu.bt_of_pexpr pe2) + in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> let unspec = CF.Undefined.UB_unspec_copy_alloc_id in @@ -1571,7 +1625,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (match action_ with | Create (pe, act, prefix) -> let@ () = WellTyped.check_ct act.loc act.ct in - let@ () = ensure_base_type loc ~expect (Loc ()) in + let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let ret_s, ret = @@ -1622,8 +1676,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = Cerb_debug.error "todo: Free" | Kill (Static ct, pe) -> let@ () = WellTyped.check_ct loc ct in - let@ () = ensure_base_type loc ~expect Unit in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect Unit in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let@ _ = RI.Special.predicate_request @@ -1638,10 +1692,15 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k (unit_ loc)) | Store (_is_locking, act, p_pe, v_pe, _mo) -> let@ () = WellTyped.check_ct act.loc act.ct in - let@ () = ensure_base_type loc ~expect Unit in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) in + let@ () = WellTyped.ensure_base_type loc ~expect Unit in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) + in let@ () = - ensure_base_type loc ~expect:(Memory.bt_of_sct act.ct) (Mu.bt_of_pexpr v_pe) + WellTyped.ensure_base_type + loc + ~expect:(Memory.bt_of_sct act.ct) + (Mu.bt_of_pexpr v_pe) in check_pexpr p_pe (fun parg -> check_pexpr v_pe (fun varg -> @@ -1680,8 +1739,10 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k (unit_ loc))) | Load (act, p_pe, _mo) -> let@ () = WellTyped.check_ct act.loc act.ct in - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) in + let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) + in check_pexpr p_pe (fun pointer -> let@ value = load loc pointer act.ct in k value) @@ -1696,7 +1757,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | LinuxStore (_ct, _sym1, _sym2, _mo) -> Cerb_debug.error "todo: LinuxStore" | LinuxRMW (_ct, _sym1, _sym2, _mo) -> Cerb_debug.error "todo: LinuxRMW") | Eskip -> - let@ () = ensure_base_type loc ~expect Unit in + let@ () = WellTyped.ensure_base_type loc ~expect Unit in k (unit_ loc) | Eccall (act, f_pe, pes) -> let@ () = WellTyped.check_ct act.loc act.ct in @@ -1708,7 +1769,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (* | _ -> fail (fun _ -> {loc; msg = Generic (Pp.item "not a function pointer at call-site" *) (* (Sctypes.pp act.ct))}) *) (* in *) - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr f_pe) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr f_pe) in check_pexpr f_pe (fun f_it -> let@ _global = get_global () in let@ fsym = known_function_pointer loc f_it in @@ -1722,7 +1783,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in (* checks pes against their annotations, and that they match ft's argument types *) Spine.calltype_ft loc ~fsym pes ft (fun (Computational ((_, bt), _, _) as rt) -> - let@ () = ensure_base_type loc ~expect bt in + let@ () = WellTyped.ensure_base_type loc ~expect bt in let@ _, members = make_return_record loc @@ -1732,10 +1793,17 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ lvt = bind_return loc members rt in k lvt)) | Eif (c_pe, e1, e2) -> - let@ () = ensure_base_type (Mu.loc_of_expr e1) ~expect (Mu.bt_of_expr e1) in - let@ () = ensure_base_type (Mu.loc_of_expr e2) ~expect (Mu.bt_of_expr e2) in let@ () = - ensure_base_type (Mu.loc_of_pexpr c_pe) ~expect:Bool (Mu.bt_of_pexpr c_pe) + WellTyped.ensure_base_type (Mu.loc_of_expr e1) ~expect (Mu.bt_of_expr e1) + in + let@ () = + WellTyped.ensure_base_type (Mu.loc_of_expr e2) ~expect (Mu.bt_of_expr e2) + in + let@ () = + WellTyped.ensure_base_type + (Mu.loc_of_pexpr c_pe) + ~expect:Bool + (Mu.bt_of_pexpr c_pe) in check_pexpr c_pe (fun carg -> let aux lc _nm e = @@ -1750,13 +1818,17 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = pure (aux (not_ carg loc) "false" e2) in return ()) | Ebound e -> - let@ () = ensure_base_type (Mu.loc_of_expr e) ~expect (Mu.bt_of_expr e) in + let@ () = + WellTyped.ensure_base_type (Mu.loc_of_expr e) ~expect (Mu.bt_of_expr e) + in check_expr labels e k | End _ -> Cerb_debug.error "todo: End" | Elet (p, e1, e2) -> - let@ () = ensure_base_type (Mu.loc_of_expr e2) ~expect (Mu.bt_of_expr e2) in let@ () = - ensure_base_type + WellTyped.ensure_base_type (Mu.loc_of_expr e2) ~expect (Mu.bt_of_expr e2) + in + let@ () = + WellTyped.ensure_base_type (Mu.loc_of_pattern p) ~expect:(Mu.bt_of_pexpr e1) (Mu.bt_of_pattern p) @@ -1767,7 +1839,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = remove_as bound_a in k rt)) | Eunseq es -> - let@ () = ensure_base_type loc ~expect (Tuple (List.map Mu.bt_of_expr es)) in + let@ () = + WellTyped.ensure_base_type loc ~expect (Tuple (List.map Mu.bt_of_expr es)) + in let rec aux es vs prev_used = match es with | e :: es' -> @@ -1820,7 +1894,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in eq_ (lhs, rhs) here in - let@ () = ensure_base_type loc ~expect Unit in + let@ () = WellTyped.ensure_base_type loc ~expect Unit in let aux loc stmt = (* copying bits of code from elsewhere in check.ml *) match stmt with @@ -1925,11 +1999,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ def = Global.get_logical_function_def loc f in let has_args, expect_args = (List.length args, List.length def.args) in let@ () = - WellTyped.ensure_same_argument_number - loc - `General - has_args - ~expect:expect_args + WellTyped.ensure_same_argument_number loc `Other has_args ~expect:expect_args in let@ args = ListM.map2M @@ -2024,9 +2094,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in loop cn_progs | Ewseq (p, e1, e2) | Esseq (p, e1, e2) -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_expr e2) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_expr e2) in let@ () = - ensure_base_type + WellTyped.ensure_base_type (Mu.loc_of_pattern p) ~expect:(Mu.bt_of_expr e1) (Mu.bt_of_pattern p) @@ -2037,7 +2107,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = remove_as bound_a in k it2)) | Erun (label_sym, pes) -> - let@ () = ensure_base_type loc ~expect Unit in + let@ () = WellTyped.ensure_base_type loc ~expect Unit in let@ lt, lkind = match Sym.Map.find_opt label_sym labels with | None -> @@ -2052,7 +2122,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let check_expr_top loc labels rt e = - let@ () = ensure_base_type loc ~expect:Unit (Mu.bt_of_expr e) in + let@ () = WellTyped.ensure_base_type loc ~expect:Unit (Mu.bt_of_expr e) in check_expr labels e (fun lvt -> let (RT.Computational ((return_s, return_bt), _info, lrt)) = rt in match return_bt with diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 26b45c570..cfad7854c 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -431,7 +431,8 @@ module EffectfulTranslation = struct let member_types = Memory.member_types def in match List.assoc_opt Id.equal member member_types with | Some ty -> return ty - | None -> fail { loc; msg = Unexpected_member (List.map fst member_types, member) } + | None -> + fail { loc; msg = Global (Unexpected_member (List.map fst member_types, member)) } let lookup_datatype loc sym env = @@ -530,7 +531,9 @@ module EffectfulTranslation = struct let reason = "map/array index" in fail { loc; - msg = Illtyped_it { it = Terms.pp e1; has = SBT.pp has; expected; reason } + msg = + WellTyped + (Illtyped_it { it = Terms.pp e1; has = SBT.pp has; expected; reason }) } in return (IT (MapGet (e1, e2), rbt, loc)) @@ -547,7 +550,8 @@ module EffectfulTranslation = struct let@ member_bt = match List.assoc_opt Id.equal member members with | Some member_bt -> return member_bt - | None -> fail { loc; msg = Unexpected_member (List.map fst members, member) } + | None -> + fail { loc; msg = Global (Unexpected_member (List.map fst members, member)) } in return (IT.recordMember_ ~member_bt (t, member) loc) | Struct tag -> @@ -572,8 +576,9 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it - { it = Terms.pp t; has = BaseTypes.Surface.pp has; expected; reason } + WellTyped + (Illtyped_it + { it = Terms.pp t; has = BaseTypes.Surface.pp has; expected; reason }) } @@ -591,7 +596,10 @@ module EffectfulTranslation = struct (fun (env, locally_bound, acc) (m, pat') -> match List.assoc_opt Id.equal m cons_info.params with | None -> - fail { loc; msg = Unexpected_member (List.map fst cons_info.params, m) } + fail + { loc; + msg = Global (Unexpected_member (List.map fst cons_info.params, m)) + } | Some mbt -> let@ env', locally_bound', pat' = translate_cn_pat env locally_bound (pat', SBT.inj mbt) @@ -650,7 +658,7 @@ module EffectfulTranslation = struct (Pp.list (fun (nm, _) -> Sym.pp nm) (Sym.Map.bindings env.computationals)))); - fail { loc; msg = Unknown_variable sym } + fail { loc; msg = WellTyped (Unknown_variable sym) } | Some (bt, None) -> return (sym, bt) | Some (bt, Some renamed_sym) -> return (renamed_sym, bt) in @@ -708,14 +716,15 @@ module EffectfulTranslation = struct fail { loc = IT.get_loc e; msg = - Illtyped_it - { it = Terms.pp e; - has = SBT.pp bt; - expected = "struct"; - reason = - (let head, pos = Locations.head_pos_of_location loc in - head ^ "\n" ^ pos) - } + WellTyped + (Illtyped_it + { it = Terms.pp e; + has = SBT.pp bt; + expected = "struct"; + reason = + (let head, pos = Locations.head_pos_of_location loc in + head ^ "\n" ^ pos) + }) }) | CNExpr_arrayindexupdates (e, updates) -> let@ e = self e in @@ -791,8 +800,9 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it - { it = Terms.pp index; has = SBT.pp has; expected; reason } + WellTyped + (Illtyped_it + { it = Terms.pp index; has = SBT.pp has; expected; reason }) }) | has -> let expected = "pointer" in @@ -800,7 +810,8 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it { it = Terms.pp base; has = SBT.pp has; expected; reason } + WellTyped + (Illtyped_it { it = Terms.pp base; has = SBT.pp has; expected; reason }) }) | CNExpr_membershift (e, opt_tag, member) -> let@ e = self e in @@ -824,8 +835,9 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it - { it = Terms.pp e; has = SBT.pp (Struct tag'); expected; reason } + WellTyped + (Illtyped_it + { it = Terms.pp e; has = SBT.pp (Struct tag'); expected; reason }) }) | Some tag, Loc None | None, Loc (Some (Struct tag)) -> with_tag tag | None, Loc None -> cannot_tell_pointee_ctype loc e @@ -834,7 +846,9 @@ module EffectfulTranslation = struct let reason = "struct member offset" in fail { loc; - msg = Illtyped_it { it = Terms.pp e; has = SBT.pp has; expected; reason } + msg = + WellTyped + (Illtyped_it { it = Terms.pp e; has = SBT.pp has; expected; reason }) }) | CNExpr_addr nm -> return (sym_ (nm, BT.Loc None, loc)) | CNExpr_cast (bt, expr) -> @@ -1053,8 +1067,9 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it - { it = Terms.pp ptr_expr; has = SBT.pp has; expected; reason } + WellTyped + (Illtyped_it + { it = Terms.pp ptr_expr; has = SBT.pp has; expected; reason }) }) in match res with @@ -1537,7 +1552,9 @@ module UsingLoads = struct | has -> let expected = "pointer" in let reason = "dereferencing" in - let msg = Illtyped_it { it = IT.pp it; has = SBT.pp has; expected; reason } in + let msg = + WellTyped (Illtyped_it { it = IT.pp it; has = SBT.pp has; expected; reason }) + in fail { loc; msg } diff --git a/backend/cn/lib/coreTypeChecks.ml b/backend/cn/lib/coreTypeChecks.ml index 5e8666e09..fc5bf7894 100644 --- a/backend/cn/lib/coreTypeChecks.ml +++ b/backend/cn/lib/coreTypeChecks.ml @@ -1,12 +1,20 @@ (* comparisons between CN base types and Core base types *) -open Effectful.Make (Or_TypeError) - module BT = BaseTypes open Cerb_frontend.Core -let check_against_core_bt fail_op core_bt cn_bt = - let fail cbt bt = +let check_against_core_bt core_bt cn_bt = + let fail msg = Result.Error msg in + let module M = struct + include Result + + type 'a t = ('a, Pp.document) Result.t + + let return = ok + end + in + let open Effectful.Make (M) in + let mismatch cbt bt = let msg1 = Pp.typ (Pp.string "mismatching core/CN types") @@ -22,7 +30,7 @@ let check_against_core_bt fail_op core_bt cn_bt = (Pp.string "inner mismatch") (Pp.ineq (Pp_mucore.pp_core_base_type cbt) (BT.pp bt))) in - fail_op msg2 + fail msg2 in let rec check_object_type = function | OTy_integer, BT.Integer -> return () @@ -32,9 +40,9 @@ let check_against_core_bt fail_op core_bt cn_bt = let@ () = check_object_type (OTy_integer, param_t) in check_object_type (t, t2) | OTy_struct tag, BT.Struct tag2 when Sym.equal tag tag2 -> return () - | OTy_union _tag, _ -> fail_op (Pp.string "unsupported: union types") - | OTy_floating, _ -> fail_op (Pp.string "unsupported: floats") - | core_obj_ty, bt -> fail (BTy_object core_obj_ty) bt + | OTy_union _tag, _ -> fail (Pp.string "unsupported: union types") + | OTy_floating, _ -> fail (Pp.string "unsupported: floats") + | core_obj_ty, bt -> mismatch (BTy_object core_obj_ty) bt in let rec check_core_base_type = function | BTy_unit, BT.Unit -> return () @@ -45,8 +53,8 @@ let check_against_core_bt fail_op core_bt cn_bt = | BTy_tuple cbts, BT.Tuple bts when List.length bts == List.length bts -> let@ _ = ListM.map2M (Tools.curry check_core_base_type) cbts bts in return () - | BTy_storable, _ -> fail_op (Pp.string "unsupported: BTy_storable") + | BTy_storable, _ -> fail (Pp.string "unsupported: BTy_storable") | BTy_ctype, BT.CType -> return () - | cbt, bt -> fail cbt bt + | cbt, bt -> mismatch cbt bt in check_core_base_type (core_bt, cn_bt) diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 87b622f6f..312d644f9 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -927,8 +927,9 @@ let rec make_largs_with_accesses f_i env st (accesses, conditions) = let is_pass_by_pointer = function By_pointer -> true | By_value -> false -let check_against_core_bt loc = - CoreTypeChecks.check_against_core_bt (fun msg -> fail { loc; msg = Generic msg }) +let check_against_core_bt loc cbt bt = + CoreTypeChecks.check_against_core_bt cbt bt + |> Result.map_error (fun msg -> TypeErrors.{ loc; msg = Generic msg }) let make_label_args f_i loc env st args (accesses, inv) = diff --git a/backend/cn/lib/diagnostics.ml b/backend/cn/lib/diagnostics.ml index b22277552..1c7edc76c 100644 --- a/backend/cn/lib/diagnostics.ml +++ b/backend/cn/lib/diagnostics.ml @@ -103,8 +103,9 @@ let split_eq x y = | IT.Apply (nm, xs), IT.Apply (nm2, ys) when Sym.equal nm nm2 -> Some (List.map2 (fun x y -> (x, y)) xs ys) | IT.Constructor (nm, xs), IT.Constructor (nm2, ys) when Sym.equal nm nm2 -> - let xs = List.sort WellTyped.compare_by_fst_id xs in - let ys = List.sort WellTyped.compare_by_fst_id ys in + let compare_fst_id (x, _) (y, _) = Id.compare x y in + let xs = List.sort compare_fst_id xs in + let ys = List.sort compare_fst_id ys in Some (List.map2 (fun (_, x) (_, y) -> (x, y)) xs ys) | _ -> None diff --git a/backend/cn/lib/global.ml b/backend/cn/lib/global.ml index 386f217b6..3b18160c2 100644 --- a/backend/cn/lib/global.ml +++ b/backend/cn/lib/global.ml @@ -58,6 +58,7 @@ type error = resource : bool } | Unknown_lemma of Sym.t + | Unexpected_member of Id.t list * Id.t (** TODO replace with actual terms *) type global_t_alias_do_not_use = t @@ -89,6 +90,8 @@ module type Lifted = sig val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_layout t + val get_member_type : Locations.t -> Id.t -> Memory.struct_piece list -> Sctypes.ctype t + val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info t val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info t @@ -121,6 +124,13 @@ module Lift (M : ErrorReader) : Lifted with type 'a t := 'a M.t = struct let get_struct_decl loc tag = lift get_struct_decl loc tag (fun _ -> Unknown_struct tag) + let get_member_type loc member layout = + let member_types = Memory.member_types layout in + match List.assoc_opt Id.equal member member_types with + | Some membertyp -> M.return membertyp + | None -> M.fail loc (Unexpected_member (List.map fst member_types, member)) + + let get_datatype loc tag = lift get_datatype loc tag (fun _ -> Unknown_datatype_constr tag) diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index e423b25a0..6013e2af7 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -113,15 +113,13 @@ end type message = | Global of Global.error - | Unexpected_member of Id.t list * Id.t - | Unknown_variable of Sym.t + | WellTyped of WellTyped.message (* some from Kayvan's compilePredicates module *) | First_iarg_missing | First_iarg_not_pointer of { pname : Request.name; found_bty : BaseTypes.t } - | Missing_member of Id.t | Missing_resource of { requests : RequestChain.t; situation : situation; @@ -139,41 +137,11 @@ type message = ctxt : Context.t * Explain.log; model : Solver.model_with_q } - | Number_members of - { has : int; - expect : int - } - | Number_arguments of - { has : int; - expect : int - } - | Number_input_arguments of - { has : int; - expect : int - } - | Number_output_arguments of - { has : int; - expect : int - } - | Mismatch of - { has : document; - expect : document - } - | Illtyped_it of - { it : document; - has : document; (* 'expected' and 'has' as in Kayvan's Core type checker *) - expected : string; - reason : string - } | Illtyped_binary_it of { left : IT.Surface.t; right : IT.Surface.t; binop : CF.Cn.cn_binop } - | NIA of - { it : IT.t; - hint : string - } | TooBigExponent : { it : IT.t } -> message | NegativeExponent : { it : IT.t } -> message | Write_value_unrepresentable of @@ -228,7 +196,7 @@ type message = ctxt : Context.t * Explain.log; model : Solver.model_with_q } - | Generic of document + | Generic of Pp.document (** TODO delete this *) | Generic_with_model of { err : document; model : Solver.model_with_q; @@ -236,10 +204,6 @@ type message = } | Unsupported of document | Parser of Cerb_frontend.Errors.cparser_cause - | Empty_pattern - | Missing_pattern of document - | Redundant_pattern of document - | Duplicate_pattern | Empty_provenance | Inconsistent_assumptions of string * (Context.t * Explain.log) | Byte_conv_needs_owned @@ -255,24 +219,20 @@ type report = state : Report.report option } -let pp_message te = - match te with - | Unknown_variable s -> - let short = !^"Unknown variable" ^^^ squotes (Sym.pp s) in - { short; descr = None; state = None } - | Global (Unknown_function sym) -> +let pp_global = function + | Global.Unknown_function sym -> let short = !^"Unknown function" ^^^ squotes (Sym.pp sym) in { short; descr = None; state = None } - | Global (Unknown_struct tag) -> + | Unknown_struct tag -> let short = !^"Struct" ^^^ squotes (Sym.pp tag) ^^^ !^"not defined" in { short; descr = None; state = None } - | Global (Unknown_datatype tag) -> + | Unknown_datatype tag -> let short = !^"Datatype" ^^^ squotes (Sym.pp tag) ^^^ !^"not defined" in { short; descr = None; state = None } - | Global (Unknown_datatype_constr tag) -> + | Unknown_datatype_constr tag -> let short = !^"Datatype constructor" ^^^ squotes (Sym.pp tag) ^^^ !^"not defined" in { short; descr = None; state = None } - | Global (Unknown_resource_predicate { id; logical }) -> + | Unknown_resource_predicate { id; logical } -> let short = !^"Unknown resource predicate" ^^^ squotes (Sym.pp id) in let descr = if logical then @@ -281,7 +241,7 @@ let pp_message te = None in { short; descr; state = None } - | Global (Unknown_logical_function { id; resource }) -> + | Unknown_logical_function { id; resource } -> let short = !^"Unknown logical function" ^^^ squotes (Sym.pp id) in let descr = if resource then @@ -290,91 +250,25 @@ let pp_message te = None in { short; descr; state = None } - | Global (Unknown_lemma sym) -> + | Unknown_lemma sym -> let short = !^"Unknown lemma" ^^^ squotes (Sym.pp sym) in { short; descr = None; state = None } | Unexpected_member (expected, member) -> let short = !^"Unexpected member" ^^^ Id.pp member in let descr = !^"the struct only has members" ^^^ list Id.pp expected in { short; descr = Some descr; state = None } - | First_iarg_missing -> - let short = !^"Missing pointer input argument" in - let descr = !^"a predicate definition must have at least one input argument" in - { short; descr = Some descr; state = None } - | First_iarg_not_pointer { pname; found_bty } -> - let short = !^"Non-pointer first input argument" in - let descr = - !^"the first input argument of predicate" - ^^^ squotes (Request.pp_name pname) - ^^^ !^"must have type" - ^^^ squotes BaseTypes.(pp (Loc ())) - ^^^ !^"but was found with type" - ^^^ squotes BaseTypes.(pp found_bty) - in - { short; descr = Some descr; state = None } - | Missing_member m -> - let short = !^"Missing member" ^^^ Id.pp m in + + +let pp_welltyped = function + | WellTyped.Global msg -> pp_global msg + | Unknown_variable s -> + let short = !^"Unknown variable" ^^^ squotes (Sym.pp s) in { short; descr = None; state = None } - | Missing_resource { requests; situation; ctxt; model } -> - let short = !^"Missing resource" ^^^ for_situation situation in - let descr = RequestChain.pp requests in - let orequest = - Option.map - (fun (r : RequestChain.elem) -> r.RequestChain.resource) - (List.nth_opt (List.rev requests) 0) - in - let state = Explain.trace ctxt model Explain.{ no_ex with request = orequest } in - { short; descr; state = Some state } - | Merging_multiple_arrays { requests; situation; ctxt; model } -> - let short = - !^"Cannot satisfy request for resource" - ^^^ for_situation situation - ^^ dot - ^^^ !^"It requires merging multiple arrays." + | Number_arguments { type_; has; expect } -> + let type_ = + match type_ with `Other -> "" | `Input -> "input" | `Output -> "output" in - let descr = RequestChain.pp requests in - let orequest = - Option.map (fun r -> r.RequestChain.resource) (List.nth_opt (List.rev requests) 0) - in - let state = Explain.trace ctxt model Explain.{ no_ex with request = orequest } in - { short; descr; state = Some state } - | Unused_resource { resource; ctxt; model } -> - let resource = Res.pp resource in - let short = !^"Left-over unused resource" ^^^ squotes resource in - let state = Explain.trace ctxt model Explain.no_ex in - { short; descr = None; state = Some state } - | Number_members { has; expect } -> - let short = !^"Wrong number of struct members" in - let descr = - !^"Expected" - ^^^ !^(string_of_int expect) - ^^ comma - ^^^ !^"has" - ^^^ !^(string_of_int has) - in - { short; descr = Some descr; state = None } - | Number_arguments { has; expect } -> - let short = !^"Wrong number of arguments" in - let descr = - !^"Expected" - ^^^ !^(string_of_int expect) - ^^ comma - ^^^ !^"has" - ^^^ !^(string_of_int has) - in - { short; descr = Some descr; state = None } - | Number_input_arguments { has; expect } -> - let short = !^"Wrong number of input arguments" in - let descr = - !^"Expected" - ^^^ !^(string_of_int expect) - ^^ comma - ^^^ !^"has" - ^^^ !^(string_of_int has) - in - { short; descr = Some descr; state = None } - | Number_output_arguments { has; expect } -> - let short = !^"Wrong number of output arguments" in + let short = !^"Wrong number" ^^^ !^type_ ^^^ !^"of arguments" in let descr = !^"Expected" ^^^ !^(string_of_int expect) @@ -419,6 +313,66 @@ let pp_message te = ^^^ !^hint in { short; descr = Some descr; state = None } + | Empty_pattern -> + let short = !^"Empty match expression." in + { short; descr = None; state = None } + | Generic err -> + let short = err in + { short; descr = None; state = None } + | Redundant_pattern p' -> + let short = !^"Redundant pattern" in + { short; descr = Some p'; state = None } + | Missing_member m -> + let short = !^"Missing member" ^^^ Id.pp m in + { short; descr = None; state = None } + + +let pp_message = function + | Global msg -> pp_global msg + | WellTyped msg -> pp_welltyped msg + | First_iarg_missing -> + let short = !^"Missing pointer input argument" in + let descr = !^"a predicate definition must have at least one input argument" in + { short; descr = Some descr; state = None } + | First_iarg_not_pointer { pname; found_bty } -> + let short = !^"Non-pointer first input argument" in + let descr = + !^"the first input argument of predicate" + ^^^ squotes (Request.pp_name pname) + ^^^ !^"must have type" + ^^^ squotes BaseTypes.(pp (Loc ())) + ^^^ !^"but was found with type" + ^^^ squotes BaseTypes.(pp found_bty) + in + { short; descr = Some descr; state = None } + | Missing_resource { requests; situation; ctxt; model } -> + let short = !^"Missing resource" ^^^ for_situation situation in + let descr = RequestChain.pp requests in + let orequest = + Option.map + (fun (r : RequestChain.elem) -> r.RequestChain.resource) + (List.nth_opt (List.rev requests) 0) + in + let state = Explain.trace ctxt model Explain.{ no_ex with request = orequest } in + { short; descr; state = Some state } + | Merging_multiple_arrays { requests; situation; ctxt; model } -> + let short = + !^"Cannot satisfy request for resource" + ^^^ for_situation situation + ^^ dot + ^^^ !^"It requires merging multiple arrays." + in + let descr = RequestChain.pp requests in + let orequest = + Option.map (fun r -> r.RequestChain.resource) (List.nth_opt (List.rev requests) 0) + in + let state = Explain.trace ctxt model Explain.{ no_ex with request = orequest } in + { short; descr; state = Some state } + | Unused_resource { resource; ctxt; model } -> + let resource = Res.pp resource in + let short = !^"Left-over unused resource" ^^^ squotes resource in + let state = Explain.trace ctxt model Explain.no_ex in + { short; descr = None; state = Some state } | TooBigExponent { it } -> let it = IT.pp it in let short = !^"Exponent too big" in @@ -564,18 +518,6 @@ let pp_message te = | Parser err -> let short = !^(Cerb_frontend.Pp_errors.string_of_cparser_cause err) in { short; descr = None; state = None } - | Empty_pattern -> - let short = !^"Empty match expression." in - { short; descr = None; state = None } - | Missing_pattern p' -> - let short = !^"Missing pattern" ^^^ squotes p' ^^ dot in - { short; descr = None; state = None } - | Redundant_pattern p' -> - let short = !^"Redundant pattern" in - { short; descr = Some p'; state = None } - | Duplicate_pattern -> - let short = !^"Duplicate pattern" in - { short; descr = None; state = None } | Empty_provenance -> let short = !^"Empty provenance" in { short; descr = None; state = None } diff --git a/backend/cn/lib/typeErrors.mli b/backend/cn/lib/typeErrors.mli index ae3f2fc64..087276d4b 100644 --- a/backend/cn/lib/typeErrors.mli +++ b/backend/cn/lib/typeErrors.mli @@ -51,14 +51,12 @@ end type message = | Global of Global.error - | Unexpected_member of Id.t list * Id.t - | Unknown_variable of Sym.t + | WellTyped of WellTyped.message | First_iarg_missing | First_iarg_not_pointer of { pname : Request.name; found_bty : BaseTypes.t } - | Missing_member of Id.t | Missing_resource of { requests : RequestChain.t; situation : situation; @@ -76,41 +74,11 @@ type message = ctxt : Context.t * Explain.log; model : Solver.model_with_q } - | Number_members of - { has : int; - expect : int - } - | Number_arguments of - { has : int; - expect : int - } - | Number_input_arguments of - { has : int; - expect : int - } - | Number_output_arguments of - { has : int; - expect : int - } - | Mismatch of - { has : Pp.document; (** TODO replace with an actual type *) - expect : Pp.document (** TODO replace with an acutal type *) - } - | Illtyped_it of - { it : Pp.document; (** TODO replace with an actual type *) - has : Pp.document; (* TODO replace with an actual type *) - expected : string; (** TODO replace with an actual type *) - reason : string (** TODO replace with an actual type *) - } | Illtyped_binary_it of { left : IndexTerms.Surface.t; right : IndexTerms.Surface.t; binop : Cerb_frontend.Cn.cn_binop } - | NIA of - { it : IndexTerms.t; - hint : string (** TODO replace with an actual type *) - } | TooBigExponent : { it : IndexTerms.t } -> message | NegativeExponent : { it : IndexTerms.t } -> message | Write_value_unrepresentable of @@ -172,10 +140,6 @@ type message = } | Unsupported of Pp.document (** TODO add source location *) | Parser of Cerb_frontend.Errors.cparser_cause - | Empty_pattern - | Missing_pattern of Pp.document (** TODO delete this *) - | Redundant_pattern of Pp.document (** TODO delete this *) - | Duplicate_pattern | Empty_provenance | Inconsistent_assumptions of string * (Context.t * Explain.log) (** TODO replace string with an actual type *) diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 9019a3777..74e58a84b 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -195,14 +195,6 @@ let modify_where (f : Where.t -> Where.t) : unit t = { s with log; typing_context }) -let get_member_type loc member layout : Sctypes.t m = - let member_types = Memory.member_types layout in - match List.assoc_opt Id.equal member member_types with - | Some membertyp -> return membertyp - | None -> - fail (fun _ -> { loc; msg = Unexpected_member (List.map fst member_types, member) }) - - module ErrorReader = struct type nonrec 'a t = 'a t @@ -215,14 +207,16 @@ module ErrorReader = struct return s.typing_context.global + let lift = function + | Ok x -> return x + | Error WellTyped.{ loc; msg } -> fail (fun _ -> { loc; msg = WellTyped msg }) + + let fail loc msg = fail (fun _ -> { loc; msg = Global msg }) let get_context () = let@ s = get () in return s.typing_context - - - let lift = lift end module Global = struct @@ -296,6 +290,8 @@ end (* end: convenient functions for global typing context *) +module WellTyped = WellTyped.Lift (ErrorReader) + let add_sym_eqs sym_eqs = modify (fun s -> let sym_eqs = @@ -525,13 +521,6 @@ let model_with_internal loc prop = (* functions for binding return types and associated auxiliary functions *) -let ensure_base_type (loc : Loc.t) ~(expect : BT.t) (has : BT.t) : unit m = - if BT.equal has expect then - return () - else - fail (fun _ -> { loc; msg = Mismatch { has = BT.pp has; expect = BT.pp expect } }) - - let make_return_record loc (record_name : string) record_members = let record_s = Sym.fresh_make_uniq record_name in (* let record_s = Sym.fresh_make_uniq (TypeErrors.call_prefix call_situation) in *) @@ -552,11 +541,13 @@ let bind_logical_return_internal loc = let rec aux members lrt = match (members, lrt) with | member :: members, LogicalReturnTypes.Define ((s, it), _, lrt) -> - let@ () = ensure_base_type loc ~expect:(IT.get_bt it) (IT.get_bt member) in + let@ () = + WellTyped.ensure_base_type loc ~expect:(IT.get_bt it) (IT.get_bt member) + in let@ () = add_c_internal (LC.T (IT.eq__ member it loc)) in aux members (LogicalReturnTypes.subst (IT.make_subst [ (s, member) ]) lrt) | member :: members, Resource ((s, (re, bt)), _, lrt) -> - let@ () = ensure_base_type loc ~expect:bt (IT.get_bt member) in + let@ () = WellTyped.ensure_base_type loc ~expect:bt (IT.get_bt member) in let@ () = add_r_internal loc (re, Res.O member) in aux members (LogicalReturnTypes.subst (IT.make_subst [ (s, member) ]) lrt) | members, Constraint (lc, _, lrt) -> @@ -577,7 +568,7 @@ let bind_logical_return loc members lrt = let bind_return loc members (rt : ReturnTypes.t) = match (members, rt) with | member :: members, Computational ((s, bt), _, lrt) -> - let@ () = ensure_base_type loc ~expect:bt (IT.get_bt member) in + let@ () = WellTyped.ensure_base_type loc ~expect:bt (IT.get_bt member) in let@ () = bind_logical_return loc @@ -783,10 +774,3 @@ let test_value_eqs loc guard x ys = let@ group = value_eq_group guard x in let@ ms = prev_models_with loc guard_it in loop group ms ys - - -module WellTyped = struct - type nonrec 'a t = 'a t - - include WellTyped.Lift (ErrorReader) -end diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index e1e70e213..881e89b9a 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -156,8 +156,6 @@ val test_value_eqs val lift : 'a Or_TypeError.t -> 'a m -val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit m - val make_return_record : Locations.t -> string -> @@ -189,4 +187,4 @@ val modify_where : (Where.t -> Where.t) -> unit m val init_solver : unit -> unit m -module WellTyped : WellTyped_intf.S with type 'a t = 'a t +module WellTyped : WellTyped_intf.S with type 'a t := 'a t diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index bd6ef4246..da7ad671f 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -9,7 +9,39 @@ let squotes, warn, dot, string, debug, item, colon, comma = Pp.(squotes, warn, dot, string, debug, item, colon, comma) -type 'a t = Context.t -> ('a * Context.t) Or_TypeError.t +type message = + | Global of Global.error + | Mismatch of + { has : Pp.document; + expect : Pp.document + } + | Generic of Pp.document (** TODO remove *) + | Illtyped_it of + { it : Pp.document; (** TODO replace with terms *) + has : Pp.document; (* 'expected' and 'has' as in Kayvan's Core type checker *) + expected : string; + reason : string + } + | Number_arguments of + { type_ : [ `Other | `Input | `Output ]; + has : int; + expect : int + } + | Missing_member of Id.t + | NIA of + { it : IT.t; + hint : string + } + | Empty_pattern + | Redundant_pattern of Pp.document + | Unknown_variable of Sym.t + +type error = + { loc : Locations.t; + msg : message + } + +type 'a t = Context.t -> ('a * Context.t, error) Result.t module GlobalReader = struct type nonrec 'a t = 'a t @@ -20,7 +52,7 @@ module GlobalReader = struct let get_global () s = Ok (s.Context.global, s) - let fail loc msg _ = Error TypeErrors.{ loc; msg = Global msg } + let fail loc msg _ = Error { loc; msg = Global msg } end module NoSolver = struct @@ -31,13 +63,6 @@ module NoSolver = struct let ( let@ ) = bind - let get_member_type loc member layout : Sctypes.t t = - let member_types = Memory.member_types layout in - match List.assoc_opt Id.equal member member_types with - | Some membertyp -> return membertyp - | None -> fail { loc; msg = Unexpected_member (List.map fst member_types, member) } - - let get_struct_member_type loc tag member = let@ decl = get_struct_decl loc tag in let@ ty = get_member_type loc member decl in @@ -62,13 +87,6 @@ module NoSolver = struct let add_l sym bt info = update (Context.add_l sym bt info) - let ensure_base_type loc ~expect has : unit t = - if BT.equal has expect then - return () - else - fail { loc; msg = Mismatch { has = BT.pp has; expect = BT.pp expect } } - - let lift = function Ok x -> return x | Error x -> fail x let run ctxt x = x ctxt @@ -80,6 +98,13 @@ open NoSolver open Effectful.Make (NoSolver) +let ensure_base_type loc ~expect has : unit t = + if BT.equal has expect then + return () + else + fail { loc; msg = Mismatch { has = BT.pp has; expect = BT.pp expect } } + + let illtyped_index_term (loc : Locations.t) it has ~expected ~reason = let reason = match reason with @@ -88,8 +113,7 @@ let illtyped_index_term (loc : Locations.t) it has ~expected ~reason = head ^ "\n" ^ pos | Either.Right reason -> reason in - TypeErrors. - { loc; msg = Illtyped_it { it = IT.pp it; has = BT.pp has; expected; reason } } + { loc; msg = Illtyped_it { it = IT.pp it; has = BT.pp has; expected; reason } } let ensure_bits_type (loc : Loc.t) (has : BT.t) = @@ -166,14 +190,11 @@ let ensure_map_type ~reason it = ~reason:(Either.Left reason)) -let ensure_same_argument_number loc input_output has ~expect = +let ensure_same_argument_number loc type_ has ~expect = if has = expect then return () - else ( - match input_output with - | `General -> fail { loc; msg = Number_arguments { has; expect } } - | `Input -> fail { loc; msg = Number_input_arguments { has; expect } } - | `Output -> fail { loc; msg = Number_output_arguments { has; expect } }) + else + fail { loc; msg = Number_arguments { type_; has; expect } } let compare_by_fst_id (x, _) (y, _) = Id.compare x y @@ -186,7 +207,7 @@ let correct_members loc (spec : (Id.t * 'a) list) (have : (Id.t * 'b) list) = if IdSet.mem id needed then return (IdSet.remove id needed) else - fail { loc; msg = Unexpected_member (List.map fst spec, id) }) + fail { loc; msg = Global (Global.Unexpected_member (List.map fst spec, id)) }) needed have in @@ -443,7 +464,7 @@ module WIT = struct match () with | () when is_a -> get_a s | () when is_l -> get_l s - | () -> fail { loc; msg = TypeErrors.Unknown_variable s } + | () -> fail { loc; msg = Unknown_variable s } in (match binding with | BaseType bt -> return (IT (Sym s, bt, loc)) @@ -537,9 +558,7 @@ module WIT = struct in warn loc msg; return (IT (Binop (DivNoSMT, t, t'), IT.get_bt t, loc)) - | _ -> - (* TODO: check for a zero divisor *) - return (IT (Binop (Div, t, t'), IT.get_bt t, loc))) + | _ -> return (IT (Binop (Div, t, t'), IT.get_bt t, loc))) | DivNoSMT -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in @@ -942,7 +961,7 @@ module WIT = struct | Apply (name, args) -> let@ def = get_logical_function_def loc name in let has_args, expect_args = (List.length args, List.length def.args) in - let@ () = ensure_same_argument_number loc `General has_args ~expect:expect_args in + let@ () = ensure_same_argument_number loc `Other has_args ~expect:expect_args in let@ args = ListM.map2M (fun has_arg (_, def_arg_bt) -> @@ -1374,7 +1393,6 @@ module WArgs = struct end module BaseTyping = struct - open TypeErrors module BT = BaseTypes module AT = ArgumentTypes open BT @@ -1382,12 +1400,9 @@ module BaseTyping = struct type label_context = (AT.lt * Where.label * Locations.t) Sym.Map.t let check_against_core_bt loc msg2 cbt bt = - lift - (CoreTypeChecks.check_against_core_bt - (fun msg -> - Or_TypeError.fail { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) - cbt - bt) + CoreTypeChecks.check_against_core_bt cbt bt + |> Result.map_error (fun msg -> { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) + |> lift module Mu = Mucore @@ -1425,14 +1440,18 @@ module BaseTyping = struct let@ _item_bt = get_item_bt bt in return (Mu.Cnil cbt, []) | Cnil _, _ -> - fail { loc; msg = Number_arguments { has = List.length pats; expect = 0 } } + let type_ = `Other in + let has = List.length pats in + fail { loc; msg = Number_arguments { type_; has; expect = 0 } } | Ccons, [ p1; p2 ] -> let@ item_bt = get_item_bt bt in let@ p1 = check_and_bind_pattern item_bt p1 in let@ p2 = check_and_bind_pattern bt p2 in return (Mu.Ccons, [ p1; p2 ]) | Ccons, _ -> - fail { loc; msg = Number_arguments { has = List.length pats; expect = 2 } } + let type_ = `Other in + let has = List.length pats in + fail { loc; msg = Number_arguments { type_; has; expect = 2 } } | Ctuple, pats -> let@ bts = match BT.is_tuple_bt bt with @@ -1703,8 +1722,9 @@ module BaseTyping = struct let@ () = ensure_base_type loc ~expect:(List ibt) (bt_of_pexpr xs) in return (bt_of_pexpr xs) | _ -> - fail - { loc; msg = Number_arguments { has = List.length pes; expect = 2 } }) + let type_ = `Other in + let has = List.length pes in + fail { loc; msg = Number_arguments { type_; has; expect = 2 } }) | Ctuple -> return (BT.Tuple (List.map bt_of_pexpr pes)) | Carray -> let ibt = bt_of_pexpr (List.hd pes) in @@ -1871,7 +1891,7 @@ module BaseTyping = struct let@ () = ensure_same_argument_number loc - `General + `Other (List.length its) ~expect:(List.length def.args) in @@ -1883,7 +1903,7 @@ module BaseTyping = struct let wrong_number_arguments () = let has = List.length its in let expect = AT.count_computational lemma_typ in - fail { loc; msg = Number_arguments { has; expect } } + fail { loc; msg = Number_arguments { type_ = `Other; has; expect } } in let rec check_args lemma_typ its = match (lemma_typ, its) with @@ -2118,7 +2138,7 @@ module BaseTyping = struct let wrong_number_arguments () = let has = List.length pes in let expect = AT.count_computational lt in - fail { loc; msg = Number_arguments { has; expect } } + fail { loc; msg = Number_arguments { type_ = `Other; has; expect } } in let rec check_args lt pes = match (lt, pes) with @@ -2449,8 +2469,6 @@ let check_term = WIT.check let check_ct = WCT.is_ct -let compare_by_fst_id = compare_by_fst_id - let ensure_same_argument_number = ensure_same_argument_number let ensure_bits_type = ensure_bits_type @@ -2464,7 +2482,7 @@ module type ErrorReader = sig val get_context : unit -> Context.t t - val lift : 'a Or_TypeError.t -> 'a t + val lift : ('a, error) Result.t -> 'a t end module Lift (M : ErrorReader) : WellTyped_intf.S with type 'a t := 'a M.t = struct @@ -2522,13 +2540,28 @@ module Lift (M : ErrorReader) : WellTyped_intf.S with type 'a t := 'a M.t = stru let check_ct = lift2 check_ct - let compare_by_fst_id = compare_by_fst_id - let ensure_same_argument_number loc type_ n ~expect = let ( let@ ) = M.bind in let@ context = M.get_context () in - M.lift (Result.map fst (ensure_same_argument_number loc type_ n ~expect context)) + M.lift + (Result.map fst (run context (ensure_same_argument_number loc type_ n ~expect))) + + + (** TODO This should be removed, but there is a discrepancy between WellTyped + and Check for base typing for bounded_binops. *) + let ensure_base_type loc ~expect has = + (* if not (BT.equal expect has) then *) + (* failwith ("has: " ^ Pp.plain (BT.pp has) ^ ", expect: " ^ Pp.plain (BT.pp expect)); *) + (* M.return () *) + let ( let@ ) = M.bind in + let@ context = M.get_context () in + M.lift (Result.map fst (run context (ensure_base_type loc has ~expect))) - let ensure_bits_type = lift2 ensure_bits_type + (** TODO If this crashes, figure out why WellTyped did not catch it earlier. + If it doesn't, then just delete it *) + let ensure_bits_type = + (* assert (match bt with BT.Bits _ -> true | _ -> false); *) + (* M.return () *) + lift2 ensure_bits_type end diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli index 22296b75e..d2e5ac199 100644 --- a/backend/cn/lib/wellTyped.mli +++ b/backend/cn/lib/wellTyped.mli @@ -1,5 +1,37 @@ val use_ity : bool ref +type message = + | Global of Global.error + | Mismatch of + { has : Pp.document; + expect : Pp.document + } + | Generic of Pp.document + | Illtyped_it of + { it : Pp.document; + has : Pp.document; + expected : string; + reason : string + } + | Number_arguments of + { type_ : [ `Other | `Input | `Output ]; + has : int; + expect : int + } + | Missing_member of Id.t + | NIA of + { it : IndexTerms.t; + hint : string + } + | Empty_pattern + | Redundant_pattern of Pp.document + | Unknown_variable of Sym.t + +type error = + { loc : Locations.t; + msg : message + } + include WellTyped_intf.S module type ErrorReader = sig @@ -11,7 +43,7 @@ module type ErrorReader = sig val get_context : unit -> Context.t t - val lift : 'a Or_TypeError.t -> 'a t + val lift : ('a, error) Result.t -> 'a t end module Lift : functor (M : ErrorReader) -> WellTyped_intf.S with type 'a t := 'a M.t diff --git a/backend/cn/lib/wellTyped_intf.ml b/backend/cn/lib/wellTyped_intf.ml index f16432e1a..d3e179f32 100644 --- a/backend/cn/lib/wellTyped_intf.ml +++ b/backend/cn/lib/wellTyped_intf.ml @@ -3,15 +3,15 @@ module type S = sig val ensure_bits_type : Locations.t -> BaseTypes.t -> unit t + val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit t + val ensure_same_argument_number : Locations.t -> - [< `General | `Input | `Output ] -> + [ `Other | `Input | `Output ] -> int -> expect:int -> unit t - val compare_by_fst_id : Id.t * 'a -> Id.t * 'b -> int - val check_ct : Locations.t -> Sctypes.ctype -> unit t val infer_term : 'bt IndexTerms.annot -> IndexTerms.t t diff --git a/tests/cn/tree16/as_mutual_dt/tree16.c.verify b/tests/cn/tree16/as_mutual_dt/tree16.c.verify index 37b1eeaf0..bcb3d7581 100644 --- a/tests/cn/tree16/as_mutual_dt/tree16.c.verify +++ b/tests/cn/tree16/as_mutual_dt/tree16.c.verify @@ -8,8 +8,8 @@ tests/cn/tree16/as_mutual_dt/tree16.c:111:19: warning: 'each' expects a 'u64', b tests/cn/tree16/as_mutual_dt/tree16.c:121:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) ^ -other location (File "backend/cn/lib/compile.ml", line 1576, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1593, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. -other location (File "backend/cn/lib/compile.ml", line 1576, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1593, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. [1/1]: lookup_rec -- pass diff --git a/tests/cn/tree16/as_partial_map/tree16.c.verify b/tests/cn/tree16/as_partial_map/tree16.c.verify index 0132fc840..80b65218d 100644 --- a/tests/cn/tree16/as_partial_map/tree16.c.verify +++ b/tests/cn/tree16/as_partial_map/tree16.c.verify @@ -14,9 +14,9 @@ tests/cn/tree16/as_partial_map/tree16.c:137:19: warning: 'each' expects a 'u64', tests/cn/tree16/as_partial_map/tree16.c:146:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) ^ -other location (File "backend/cn/lib/compile.ml", line 1576, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1593, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. -other location (File "backend/cn/lib/compile.ml", line 1576, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. +other location (File "backend/cn/lib/compile.ml", line 1593, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. [1/2]: cn_get_num_nodes -- pass [2/2]: lookup_rec -- pass From c601ccf3580b560ed4ff3041e37a3804c511822c Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Mon, 30 Dec 2024 16:32:05 -0500 Subject: [PATCH 145/148] [CN-Test-Gen] Fix #802 --- backend/cn/lib/testGeneration/genOptimize.ml | 73 +++++++++++--------- tests/cn-test-gen/src/sized_array.pass.c | 12 ++++ 2 files changed, 53 insertions(+), 32 deletions(-) create mode 100644 tests/cn-test-gen/src/sized_array.pass.c diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index b25802e8f..bbf852d2f 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -175,39 +175,48 @@ module Fusion = struct let gt_rest, constraints = collect_constraints (Sym.Set.add x vars) x its_bounds gt_rest in - let gt_inner = - let stmts, gt_last = GS.stmts_of_gt (aux (Sym.Set.add i vars) gt_inner) in - let sym_bt, stmts', gt_last = - match gt_last with - | GT (Return (IT (Sym x, x_bt, _)), _, _) -> ((x, x_bt), [], gt_last) - | GT (Return it, ret_bt, loc_ret) -> - let here = Locations.other __LOC__ in - let y = Sym.fresh () in - ( (y, ret_bt), - [ GS.Let (0, (y, GT.return_ it loc_ret)) ], - GT.return_ (IT.sym_ (y, ret_bt, here)) loc_ret ) - | _ -> failwith (Pp.plain (GT.pp gt_last) ^ " @ " ^ __LOC__) - in - let here = Locations.other __LOC__ in - let stmts'' = - List.map - (fun (j, lc) : GS.t -> - Assert - (LC.T - (replace_index - x - sym_bt - i - (IT.subst (IT.make_subst [ (j, IT.sym_ (i, i_bt, here)) ]) lc)))) - constraints + if List.is_empty constraints then + gt + else ( + let gt_inner = + let stmts, gt_last = GS.stmts_of_gt (aux (Sym.Set.add i vars) gt_inner) in + let sym_bt, stmts', gt_last = + match gt_last with + | GT (Return (IT (Sym x, x_bt, _)), _, _) -> ((x, x_bt), [], gt_last) + | GT (Return it, ret_bt, loc_ret) -> + let here = Locations.other __LOC__ in + let y = Sym.fresh () in + ( (y, ret_bt), + [ GS.Let (0, (y, GT.return_ it loc_ret)) ], + GT.return_ (IT.sym_ (y, ret_bt, here)) loc_ret ) + | gt' -> + let ret_bt = GT.bt gt' in + let here = Locations.other __LOC__ in + let y = Sym.fresh () in + ( (y, ret_bt), + [ GS.Let (0, (y, gt')) ], + GT.return_ (IT.sym_ (y, ret_bt, here)) (GT.loc gt') ) + in + let here = Locations.other __LOC__ in + let stmts'' = + List.map + (fun (j, lc) : GS.t -> + Assert + (LC.T + (replace_index + x + sym_bt + i + (IT.subst (IT.make_subst [ (j, IT.sym_ (i, i_bt, here)) ]) lc)))) + constraints + in + GS.gt_of_stmts (stmts @ stmts' @ stmts'') gt_last in - GS.gt_of_stmts (stmts @ stmts' @ stmts'') gt_last - in - GT.let_ - ( backtracks, - (x, GT.map_ ((i, i_bt, it_perm), gt_inner) loc_map), - aux (Sym.Set.add x vars) gt_rest ) - loc + GT.let_ + ( backtracks, + (x, GT.map_ ((i, i_bt, it_perm), gt_inner) loc_map), + aux (Sym.Set.add x vars) gt_rest ) + loc) | Let (backtracks, (x, gt_inner), gt_rest) -> GT.let_ (backtracks, (x, aux vars gt_inner), aux (Sym.Set.add x vars) gt_rest) diff --git a/tests/cn-test-gen/src/sized_array.pass.c b/tests/cn-test-gen/src/sized_array.pass.c new file mode 100644 index 000000000..4931eba82 --- /dev/null +++ b/tests/cn-test-gen/src/sized_array.pass.c @@ -0,0 +1,12 @@ +struct foo { + int bar[16]; +}; + +void test_gen_const_array(struct foo* c) +/*@ +requires take Client_in = Owned(c); +ensures take Client_out = Owned(c); +@*/ +{ + return; +} From 6fc4ec493597b5221a472c058fd63f36664b687f Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 2 Jan 2025 03:01:30 -0500 Subject: [PATCH 146/148] [CN-Test-Gen] Organize top-level test generation (#806) --- backend/cn/lib/testGeneration/buildScript.ml | 202 +++++++ backend/cn/lib/testGeneration/buildScript.mli | 1 + backend/cn/lib/testGeneration/genCompile.ml | 2 +- backend/cn/lib/testGeneration/specTests.ml | 513 +++--------------- backend/cn/lib/testGeneration/specTests.mli | 20 +- backend/cn/lib/testGeneration/test.ml | 14 + .../cn/lib/testGeneration/testGeneration.ml | 219 +++++++- runtime/libcn/include/cn-testing/test.h | 54 +- runtime/libcn/src/cn-testing/test.c | 10 +- 9 files changed, 551 insertions(+), 484 deletions(-) create mode 100644 backend/cn/lib/testGeneration/buildScript.ml create mode 100644 backend/cn/lib/testGeneration/buildScript.mli create mode 100644 backend/cn/lib/testGeneration/test.ml diff --git a/backend/cn/lib/testGeneration/buildScript.ml b/backend/cn/lib/testGeneration/buildScript.ml new file mode 100644 index 000000000..3aec09b0e --- /dev/null +++ b/backend/cn/lib/testGeneration/buildScript.ml @@ -0,0 +1,202 @@ +module Config = TestGenConfig +open Pp + +let setup ~output_dir = + string "#!/bin/bash" + ^^ twice hardline + ^^ string "# copied from cn-runtime-single-file.sh" + ^^ hardline + ^^ string "RUNTIME_PREFIX=\"$OPAM_SWITCH_PREFIX/lib/cn/runtime\"" + ^^ hardline + ^^ string "[ -d \"${RUNTIME_PREFIX}\" ]" + ^^ space + ^^ twice bar + ^^ space + ^^ parens + (nest + 4 + (hardline + ^^ string + "printf \"Could not find CN's runtime directory (looked at: \ + '${RUNTIME_PREFIX}')\"" + ^^ hardline + ^^ string "exit 1") + ^^ hardline) + ^^ twice hardline + ^^ string ("TEST_DIR=" ^ Filename.dirname (Filename.concat output_dir "junk")) + ^^ hardline + ^^ string "pushd $TEST_DIR > /dev/null" + ^^ hardline + + +let attempt cmd success failure = + separate_map space string [ "if"; cmd; ";"; "then" ] + ^^ nest 4 (hardline ^^ string ("echo \"" ^ success ^ "\"")) + ^^ hardline + ^^ string "else" + ^^ nest + 4 + (hardline ^^ string ("printf \"" ^ failure ^ "\"") ^^ hardline ^^ string "exit 1") + ^^ hardline + ^^ string "fi" + + +let compile ~test_file = + string "# Compile" + ^^ hardline + ^^ attempt + (String.concat + " " + ([ "cc"; + "-g"; + "-c"; + "\"-I${RUNTIME_PREFIX}/include/\""; + "-o"; + "\"./" ^ Filename.chop_extension test_file ^ ".o\""; + "\"./" ^ test_file ^ "\"" + ] + @ + if Config.is_coverage () then + [ "--coverage" ] + else + [])) + "Compiled C files." + "Failed to compile C files in ${TEST_DIR}." + ^^ hardline + + +let link ~test_file = + string "# Link" + ^^ hardline + ^^ attempt + (String.concat + " " + ([ "cc"; + "-g"; + "\"-I${RUNTIME_PREFIX}/include\""; + "-o"; + "\"./tests.out\""; + Filename.chop_extension test_file ^ ".o"; + "\"${RUNTIME_PREFIX}/libcn.a\"" + ] + @ + if Config.is_coverage () then + [ "--coverage" ] + else + [])) + "Linked C *.o files." + "Failed to link *.o files in ${TEST_DIR}." + ^^ hardline + + +let run () = + let cmd = + separate_map + space + string + ([ "./tests.out" ] + @ (Config.has_input_timeout () + |> Option.map (fun input_timeout -> + [ "--input-timeout"; string_of_int input_timeout ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_null_in_every () + |> Option.map (fun null_in_every -> + [ "--null-in-every"; string_of_int null_in_every ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_seed () + |> Option.map (fun seed -> [ "--seed"; seed ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_logging_level () + |> Option.map (fun level -> [ "--logging-level"; string_of_int level ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_progress_level () + |> Option.map (fun level -> [ "--progress-level"; string_of_int level ]) + |> Option.to_list + |> List.flatten) + @ (if Config.is_interactive () then + [ "--interactive" ] + else + []) + @ (match Config.is_until_timeout () with + | Some timeout -> [ "--until-timeout"; string_of_int timeout ] + | None -> []) + @ (if Config.is_exit_fast () then + [ "--exit-fast" ] + else + []) + @ (Config.has_max_stack_depth () + |> Option.map (fun max_stack_depth -> + [ "--max-stack-depth"; string_of_int max_stack_depth ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_max_generator_size () + |> Option.map (fun max_generator_size -> + [ "--max-generator-size"; string_of_int max_generator_size ]) + |> Option.to_list + |> List.flatten) + @ (if Config.is_sized_null () then + [ "--sized-null" ] + else + []) + @ (Config.has_allowed_depth_failures () + |> Option.map (fun allowed_depth_failures -> + [ "--allowed-depth-failures"; string_of_int allowed_depth_failures ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_allowed_size_split_backtracks () + |> Option.map (fun allowed_size_split_backtracks -> + [ "--allowed-size-split-backtracks"; + string_of_int allowed_size_split_backtracks + ]) + |> Option.to_list + |> List.flatten)) + in + string "# Run" + ^^ hardline + ^^ cmd + ^^ hardline + ^^ string "test_exit_code=$? # Save tests exit code for later" + ^^ hardline + + +let coverage ~test_file = + string "# Coverage" + ^^ hardline + ^^ attempt + ("gcov \"" ^ test_file ^ "\"") + "Recorded coverage via gcov." + "Failed to record coverage." + ^^ twice hardline + ^^ attempt + "lcov --capture --directory . --output-file coverage.info" + "Collected coverage via lcov." + "Failed to collect coverage." + ^^ twice hardline + ^^ attempt + "genhtml --output-directory html \"coverage.info\"" + "Generated HTML report at \\\"${TEST_DIR}/html/\\\"." + "Failed to generate HTML report." + ^^ hardline + + +let generate ~(output_dir : string) ~(test_file : string) : Pp.document = + setup ~output_dir + ^^ hardline + ^^ compile ~test_file + ^^ hardline + ^^ link ~test_file + ^^ hardline + ^^ run () + ^^ hardline + ^^ (if Config.is_coverage () then + coverage ~test_file ^^ hardline + else + empty) + ^^ string "popd > /dev/null" + ^^ hardline + ^^ string "exit $test_exit_code" + ^^ hardline diff --git a/backend/cn/lib/testGeneration/buildScript.mli b/backend/cn/lib/testGeneration/buildScript.mli new file mode 100644 index 000000000..45de35f3d --- /dev/null +++ b/backend/cn/lib/testGeneration/buildScript.mli @@ -0,0 +1 @@ +val generate : output_dir:string -> test_file:string -> Pp.document diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index 87e84d250..17cdf045a 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -326,7 +326,7 @@ let compile_spec : unit m = (* Necessary to avoid triggering special-cased logic in [CtA] w.r.t globals *) - let rename x = Sym.fresh_named ("cn_gen_" ^ Sym.pp_string x) in + let rename x = GenUtils.get_mangled_name [ x ] in let lat = let lat = AT.get_lat at in let subst = diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 67c921d3c..d261bb501 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -5,12 +5,20 @@ module AT = ArgumentTypes module LAT = LogicalArgumentTypes module CtA = Cn_internal_to_ail module Utils = Executable_spec_utils -module ESpecInternal = Executable_spec_internal module Config = TestGenConfig let debug_log_file : out_channel option ref = ref None +let init_debug () = + if Option.is_none !debug_log_file && !Cerb_debug.debug_level > 0 then + debug_log_file + := Some + (let open Stdlib in + open_out "generatorCompilation.log") + + let debug_log (str : string) : unit = + init_debug (); match !debug_log_file with | Some oc -> output_string oc str; @@ -23,41 +31,42 @@ let debug_stage (stage : string) (str : string) : unit = debug_log (str ^ "\n\n") -let pp_label ?(width : int = 30) (label : string) : Pp.document = - let padding = max 2 ((width - (String.length label + 2)) / 2) in - let open Pp in - repeat width slash - ^^ hardline - ^^ repeat padding slash - ^^ space - ^^ string label - ^^ space - ^^ repeat padding slash - ^^ hardline - ^^ repeat width slash - - -let compile_unit_tests (insts : Executable_spec_extract.instrumentation list) = +let compile_constant_tests (insts : Executable_spec_extract.instrumentation list) + : Test.t list * Pp.document + = + let test_names, docs = + List.map_split + (fun (inst : Executable_spec_extract.instrumentation) -> + ( Test. + { kind = Constant; + suite = + inst.fn_loc + |> Cerb_location.get_filename + |> Option.get + |> Filename.basename + |> String.split_on_char '.' + |> List.hd; + test = Sym.pp_string inst.fn + }, + CF.Pp_ail.pp_statement + A.( + Utils.mk_stmt + (AilSexpr + (Utils.mk_expr + (AilEcall + ( Utils.mk_expr (AilEident (Sym.fresh_named "CN_UNIT_TEST_CASE")), + [ Utils.mk_expr (AilEident inst.fn) ] ))))) )) + insts + in let open Pp in - separate_map - (semi ^^ twice hardline) - (fun (inst : Executable_spec_extract.instrumentation) -> - CF.Pp_ail.pp_statement - A.( - Utils.mk_stmt - (AilSexpr - (Utils.mk_expr - (AilEcall - ( Utils.mk_expr (AilEident (Sym.fresh_named "CN_UNIT_TEST_CASE")), - [ Utils.mk_expr (AilEident inst.fn) ] )))))) - insts + (test_names, separate (semi ^^ twice hardline) docs ^^ twice hardline) let compile_generators (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) (insts : Executable_spec_extract.instrumentation list) - : PPrint.document + : Pp.document = let ctx = GenCompile.compile prog5.resource_predicates insts in debug_stage "Compile" (ctx |> GenDefinitions.pp_context |> Pp.plain ~width:80); @@ -78,7 +87,7 @@ let compile_random_test_case (prog5 : unit Mucore.file) (args_map : (Sym.t * (Sym.t * C.ctype) list) list) (convert_from : Sym.t * C.ctype -> Pp.document) - (inst : Executable_spec_extract.instrumentation) + ((test, inst) : Test.t * Executable_spec_extract.instrumentation) : Pp.document = let open Pp in @@ -106,7 +115,7 @@ let compile_random_test_case (if List.is_empty globals then string "CN_RANDOM_TEST_CASE" else ( - let init_name = string "cn_test_" ^^ Sym.pp inst.fn ^^ string "_init" in + let init_name = string "cn_test_gen_" ^^ Sym.pp inst.fn ^^ string "_init" in string "void" ^^ space ^^ init_name @@ -139,7 +148,8 @@ let compile_random_test_case ^^ star ^^ parens (ty ^^ star) ^^ string "convert_from_cn_pointer" - ^^ parens (string "res->cn_gen_" ^^ Sym.pp sym) + ^^ parens + (string "res->" ^^ Sym.pp (GenUtils.get_mangled_name [ sym ])) ^^ semi ^^ hardline ^^ string "cn_assume_ownership" @@ -158,25 +168,19 @@ let compile_random_test_case ^^ parens (separate (comma ^^ space) - [ inst.fn_loc - |> Cerb_location.get_filename - |> Option.get - |> Filename.basename - |> String.split_on_char '.' - |> List.hd - |> string; - Sym.pp inst.fn; + [ string test.suite; + string test.test; int (Config.get_num_samples ()); separate_map (comma ^^ space) convert_from args ]) ^^ twice hardline -let compile_random_tests +let compile_generator_tests (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) (insts : Executable_spec_extract.instrumentation list) - : Pp.document + : Test.t list * Pp.document = let declarations : A.sigma_declaration list = insts @@ -209,410 +213,29 @@ let compile_random_tests A.( AilEmemberofptr ( Utils.mk_expr (AilEident (Sym.fresh_named "res")), - Sym.Identifier (Locations.other __LOC__, "cn_gen_" ^ Sym.pp_string x) )) + Sym.Identifier + ( Locations.other __LOC__, + Sym.pp_string (GenUtils.get_mangled_name [ x ]) ) )) (Memory.bt_of_sct (Sctypes.of_ctype_unsafe (Locations.other __LOC__) ct)))) in - let open Pp in - concat_map (compile_random_test_case prog5 args_map convert_from) insts - - -let compile_assumes - ~(without_ownership_checking : bool) - (sigma : CF.GenTypes.genTypeCategory A.sigma) - (prog5 : unit Mucore.file) - (insts : Executable_spec_extract.instrumentation list) - : Pp.document - = - let declarations, function_definitions = - List.split - (List.map - (fun ctype -> - Cn_internal_to_ail.generate_assume_ownership_function - ~without_ownership_checking - ctype) - (let module CtypeSet = - Set.Make (struct - type t = C.ctype - - let compare a b = compare (Hashtbl.hash a) (Hashtbl.hash b) - end) - in - !CtA.ownership_ctypes |> CtypeSet.of_list |> CtypeSet.to_seq |> List.of_seq) - @ Cn_internal_to_ail.cn_to_ail_assume_predicates_internal - prog5.resource_predicates - sigma.cn_datatypes - [] - prog5.resource_predicates - @ ESpecInternal.generate_c_assume_pres_internal insts sigma prog5) + let tests = + List.map + (fun (inst : Executable_spec_extract.instrumentation) -> + Test. + { kind = Generator; + suite = + inst.fn_loc + |> Cerb_location.get_filename + |> Option.get + |> Filename.basename + |> String.split_on_char '.' + |> List.hd; + test = Sym.pp_string inst.fn + }) + insts in let open Pp in - separate_map - (twice hardline) - (fun (tag, (_, _, decl)) -> - CF.Pp_ail.pp_function_prototype ~executable_spec:true tag decl) - declarations - ^^ twice hardline - ^^ CF.Pp_ail.pp_program - ~executable_spec:true - ~show_include:true - (None, { A.empty_sigma with declarations; function_definitions }) - - -let should_be_unit_test - (sigma : CF.GenTypes.genTypeCategory A.sigma) - (inst : Executable_spec_extract.instrumentation) - = - let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in - match decl with - | Decl_function (_, _, args, _, _, _) -> - List.is_empty args - && Sym.Set.is_empty - (LAT.free_vars (fun _ -> Sym.Set.empty) (AT.get_lat (Option.get inst.internal))) - | Decl_object _ -> failwith __LOC__ - - -let compile_tests - ~(without_ownership_checking : bool) - (filename_base : string) - (sigma : CF.GenTypes.genTypeCategory A.sigma) - (prog5 : unit Mucore.file) - (insts : Executable_spec_extract.instrumentation list) - = - let unit_tests, random_tests = List.partition (should_be_unit_test sigma) insts in - let unit_tests_doc = compile_unit_tests unit_tests in - let random_tests_doc = compile_random_tests sigma prog5 random_tests in - let open Pp in - string "#include " - ^^ dquotes (string (filename_base ^ "_gen.h")) - ^^ hardline - ^^ string "#include " - ^^ dquotes (string (filename_base ^ "-exec.c")) - ^^ hardline - ^^ string "#include " - ^^ dquotes (string "cn.c") - ^^ twice hardline - ^^ pp_label "Assume Ownership Functions" - ^^ twice hardline - ^^ compile_assumes ~without_ownership_checking sigma prog5 insts - ^^ pp_label "Unit tests" - ^^ twice hardline - ^^ unit_tests_doc - ^^ twice hardline - ^^ pp_label "Random tests" - ^^ twice hardline - ^^ random_tests_doc - ^^ pp_label "Main function" - ^^ twice hardline - ^^ string "int main" - ^^ parens (string "int argc, char* argv[]") - ^^ break 1 - ^^ braces - (nest - 2 - (hardline - ^^ concat_map - (fun decl -> - let fn, (loc, _, _) = decl in - let suite = - loc - |> Cerb_location.get_filename - |> Option.get - |> Filename.basename - |> String.split_on_char '.' - |> List.hd - in - string "cn_register_test_case" - ^^ parens - (separate - (comma ^^ space) - [ string "(char*)" ^^ dquotes (string suite); - string "(char*)" ^^ dquotes (Sym.pp fn); - string "&cn_test" ^^ underscore ^^ Sym.pp fn - ]) - ^^ semi - ^^ hardline) - (List.map - (fun (inst : Executable_spec_extract.instrumentation) -> - (inst.fn, List.assoc Sym.equal inst.fn sigma.declarations)) - insts) - ^^ string "return cn_test_main(argc, argv);") - ^^ hardline) - ^^ hardline - - -let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = - let open Pp in - string "#!/bin/bash" - ^^ twice hardline - ^^ string "# copied from cn-runtime-single-file.sh" - ^^ hardline - ^^ string "RUNTIME_PREFIX=\"$OPAM_SWITCH_PREFIX/lib/cn/runtime\"" - ^^ hardline - ^^ string "[ -d \"${RUNTIME_PREFIX}\" ]" - ^^ space - ^^ twice bar - ^^ space - ^^ parens - (nest - 4 - (hardline - ^^ string - "printf \"Could not find CN's runtime directory (looked at: \ - '${RUNTIME_PREFIX}')\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline) - ^^ twice hardline - ^^ string ("TEST_DIR=" ^ Filename.dirname (Filename.concat output_dir "junk")) - ^^ hardline - ^^ string "pushd $TEST_DIR > /dev/null" - ^^ twice hardline - ^^ string "# Compile" - ^^ hardline - ^^ separate_map - space - string - [ "if"; - "cc"; - "-g"; - "-c"; - "\"-I${RUNTIME_PREFIX}/include/\""; - "-o"; - "\"./" ^ Filename.chop_extension test_file ^ ".o\""; - "\"./" ^ test_file ^ "\""; - (if Config.is_coverage () then "--coverage;" else ";"); - "then" - ] - ^^ nest 4 (hardline ^^ string "echo \"Compiled C files.\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to compile C files in ${TEST_DIR}.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ twice hardline - ^^ string "# Link" - ^^ hardline - ^^ separate_map - space - string - [ "if"; - "cc"; - "-g"; - "\"-I${RUNTIME_PREFIX}/include\""; - "-o"; - "\"./tests.out\""; - Filename.chop_extension test_file ^ ".o"; - "\"${RUNTIME_PREFIX}/libcn.a\""; - (if Config.is_coverage () then "--coverage;" else ";"); - "then" - ] - ^^ nest 4 (hardline ^^ string "echo \"Linked C .o files.\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to link *.o files in ${TEST_DIR}.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ twice hardline - ^^ string "# Run" - ^^ hardline - ^^ - let cmd = - separate_map - space - string - ([ "./tests.out" ] - @ (Config.has_input_timeout () - |> Option.map (fun input_timeout -> - [ "--input-timeout"; string_of_int input_timeout ]) - |> Option.to_list - |> List.flatten) - @ (Config.has_null_in_every () - |> Option.map (fun null_in_every -> - [ "--null-in-every"; string_of_int null_in_every ]) - |> Option.to_list - |> List.flatten) - @ (Config.has_seed () - |> Option.map (fun seed -> [ "--seed"; seed ]) - |> Option.to_list - |> List.flatten) - @ (Config.has_logging_level () - |> Option.map (fun level -> [ "--logging-level"; string_of_int level ]) - |> Option.to_list - |> List.flatten) - @ (Config.has_progress_level () - |> Option.map (fun level -> [ "--progress-level"; string_of_int level ]) - |> Option.to_list - |> List.flatten) - @ (if Config.is_interactive () then - [ "--interactive" ] - else - []) - @ (match Config.is_until_timeout () with - | Some timeout -> [ "--until-timeout"; string_of_int timeout ] - | None -> []) - @ (if Config.is_exit_fast () then - [ "--exit-fast" ] - else - []) - @ (Config.has_max_stack_depth () - |> Option.map (fun max_stack_depth -> - [ "--max-stack-depth"; string_of_int max_stack_depth ]) - |> Option.to_list - |> List.flatten) - @ (Config.has_max_generator_size () - |> Option.map (fun max_generator_size -> - [ "--max-generator-size"; string_of_int max_generator_size ]) - |> Option.to_list - |> List.flatten) - @ (if Config.is_sized_null () then - [ "--sized-null" ] - else - []) - @ (Config.has_allowed_depth_failures () - |> Option.map (fun allowed_depth_failures -> - [ "--allowed-depth-failures"; string_of_int allowed_depth_failures ]) - |> Option.to_list - |> List.flatten) - @ (Config.has_allowed_size_split_backtracks () - |> Option.map (fun allowed_size_split_backtracks -> - [ "--allowed-size-split-backtracks"; - string_of_int allowed_size_split_backtracks - ]) - |> Option.to_list - |> List.flatten)) - in - cmd - ^^ hardline - ^^ string "test_exit_code=$? # Save tests exit code for later" - ^^ twice hardline - ^^ hardline - ^^ (if Config.is_coverage () then - hardline - ^^ string "# Coverage" - ^^ hardline - ^^ string ("if gcov \"" ^ test_file ^ "\"; then") - ^^ nest 4 (hardline ^^ string "echo \"Recorded coverage via gcov.\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to record coverage.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ twice hardline - ^^ string "if lcov --capture --directory . --output-file coverage.info; then" - ^^ nest 4 (hardline ^^ string "echo \"Collected coverage via lcov.\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to collect coverage.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ twice hardline - ^^ separate_map - space - string - [ "if"; - "genhtml"; - "--output-directory"; - "html"; - "\"coverage.info\";"; - "then" - ] - ^^ nest - 4 - (hardline - ^^ string "echo \"Generated HTML report at \\\"${TEST_DIR}/html/\\\".\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to generate HTML report.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - else - empty) - ^^ twice hardline - ^^ string "popd > /dev/null" - ^^ twice hardline - ^^ string "exit $test_exit_code" - ^^ hardline - - -let save ?(perm = 0o666) (output_dir : string) (filename : string) (doc : Pp.document) - : unit - = - let oc = - Stdlib.open_out_gen - [ Open_wronly; Open_creat; Open_trunc; Open_text ] - perm - (Filename.concat output_dir filename) - in - output_string oc (Pp.plain ~width:80 doc); - close_out oc - - -let generate - ~(output_dir : string) - ~(filename : string) - ~(without_ownership_checking : bool) - (sigma : CF.GenTypes.genTypeCategory A.sigma) - (prog5 : unit Mucore.file) - : unit - = - if !Cerb_debug.debug_level > 0 then - debug_log_file - := Some - (let open Stdlib in - open_out "generatorCompilation.log"); - let insts = prog5 |> Executable_spec_extract.collect_instrumentation |> fst in - let selected_fsyms = - Check.select_functions - (Sym.Set.of_list - (List.map - (fun (inst : Executable_spec_extract.instrumentation) -> inst.fn) - insts)) - in - let insts = - insts - |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> - Option.is_some inst.internal && Sym.Set.mem inst.fn selected_fsyms) - in - if List.is_empty insts then failwith "No testable functions"; - let filename_base = filename |> Filename.basename |> Filename.chop_extension in - let generators_doc = - compile_generators - sigma - prog5 - (List.filter (fun inst -> not (should_be_unit_test sigma inst)) insts) - in - let generators_fn = filename_base ^ "_gen.h" in - save output_dir generators_fn generators_doc; - let tests_doc = - compile_tests ~without_ownership_checking filename_base sigma prog5 insts - in - let test_file = filename_base ^ "_test.c" in - save output_dir test_file tests_doc; - let script_doc = compile_script ~output_dir ~test_file in - save ~perm:0o777 output_dir "run_tests.sh" script_doc; - () + ( tests, + concat_map + (compile_random_test_case prog5 args_map convert_from) + (List.combine tests insts) ) diff --git a/backend/cn/lib/testGeneration/specTests.mli b/backend/cn/lib/testGeneration/specTests.mli index a6726e89a..6e9915cdb 100644 --- a/backend/cn/lib/testGeneration/specTests.mli +++ b/backend/cn/lib/testGeneration/specTests.mli @@ -1,10 +1,18 @@ module CF = Cerb_frontend module A = CF.AilSyntax -val generate - : output_dir:string -> - filename:string -> - without_ownership_checking:bool -> - CF.GenTypes.genTypeCategory A.sigma -> +val compile_constant_tests + : Executable_spec_extract.instrumentation list -> + Test.t list * Pp.document + +val compile_generators + : CF.GenTypes.genTypeCategory A.sigma -> + unit Mucore.file -> + Executable_spec_extract.instrumentation list -> + Pp.document + +val compile_generator_tests + : CF.GenTypes.genTypeCategory A.sigma -> unit Mucore.file -> - unit + Executable_spec_extract.instrumentation list -> + Test.t list * Pp.document diff --git a/backend/cn/lib/testGeneration/test.ml b/backend/cn/lib/testGeneration/test.ml new file mode 100644 index 000000000..b0e06eb23 --- /dev/null +++ b/backend/cn/lib/testGeneration/test.ml @@ -0,0 +1,14 @@ +type kind = + | Constant (* Run function without arguments nor `accesses` once *) + | Generator (* Run function with random inputs satisfying the precondition *) + +type t = + { kind : kind; + suite : string; + test : string + } + +let registration_macro (test : t) : string = + match test.kind with + | Constant -> "CN_REGISTER_UNIT_TEST_CASE" + | Generator -> "CN_REGISTER_RANDOM_TEST_CASE" diff --git a/backend/cn/lib/testGeneration/testGeneration.ml b/backend/cn/lib/testGeneration/testGeneration.ml index b91610659..4f994b3a1 100644 --- a/backend/cn/lib/testGeneration/testGeneration.ml +++ b/backend/cn/lib/testGeneration/testGeneration.ml @@ -1,21 +1,232 @@ +module CF = Cerb_frontend +module A = CF.AilSyntax +module C = CF.Ctype +module AT = ArgumentTypes +module LAT = LogicalArgumentTypes +module CtA = Cn_internal_to_ail +module ESpecInternal = Executable_spec_internal module Config = TestGenConfig type config = Config.t let default_cfg : config = Config.default +let is_constant_function + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (inst : Executable_spec_extract.instrumentation) + = + let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in + match decl with + | Decl_function (_, _, args, _, _, _) -> + List.is_empty args + && Sym.Set.is_empty + (LAT.free_vars (fun _ -> Sym.Set.empty) (AT.get_lat (Option.get inst.internal))) + | Decl_object _ -> failwith __LOC__ + + +let compile_assumes + ~(without_ownership_checking : bool) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + (insts : Executable_spec_extract.instrumentation list) + : Pp.document + = + let declarations, function_definitions = + List.split + (List.map + (fun ctype -> + Cn_internal_to_ail.generate_assume_ownership_function + ~without_ownership_checking + ctype) + (let module CtypeSet = + Set.Make (struct + type t = C.ctype + + let compare a b = compare (Hashtbl.hash a) (Hashtbl.hash b) + end) + in + !CtA.ownership_ctypes |> CtypeSet.of_list |> CtypeSet.to_seq |> List.of_seq) + @ Cn_internal_to_ail.cn_to_ail_assume_predicates_internal + prog5.resource_predicates + sigma.cn_datatypes + [] + prog5.resource_predicates + @ ESpecInternal.generate_c_assume_pres_internal insts sigma prog5) + in + let open Pp in + separate_map + (twice hardline) + (fun (tag, (_, _, decl)) -> + CF.Pp_ail.pp_function_prototype ~executable_spec:true tag decl) + declarations + ^^ twice hardline + ^^ CF.Pp_ail.pp_program + ~executable_spec:true + ~show_include:true + (None, { A.empty_sigma with declarations; function_definitions }) + ^^ hardline + + +let pp_label ?(width : int = 30) (label : string) (doc : Pp.document) : Pp.document = + let padding = max 2 ((width - (String.length label + 2)) / 2) in + let width = max width (String.length label + 6) in + let open Pp in + if PPrint.requirement doc = 0 then + empty + else + repeat width slash + ^^ hardline + ^^ repeat + (if String.length label mod 2 = 1 then + padding + 1 + else + padding) + slash + ^^ space + ^^ string label + ^^ space + ^^ repeat padding slash + ^^ hardline + ^^ repeat width slash + ^^ twice hardline + ^^ doc + + +let compile_test_file + ~(without_ownership_checking : bool) + (filename_base : string) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + (insts : Executable_spec_extract.instrumentation list) + = + let for_constant, for_generator = List.partition (is_constant_function sigma) insts in + let constant_tests, constant_tests_defs = + SpecTests.compile_constant_tests for_constant + in + let generator_tests, generator_tests_defs = + SpecTests.compile_generator_tests sigma prog5 for_generator + in + let tests = [ constant_tests; generator_tests ] in + let open Pp in + string "#include " + ^^ dquotes (string (filename_base ^ "_gen.h")) + ^^ hardline + ^^ string "#include " + ^^ dquotes (string (filename_base ^ "-exec.c")) + ^^ hardline + ^^ string "#include " + ^^ dquotes (string "cn.c") + ^^ twice hardline + ^^ pp_label + "Assume Ownership Functions" + (compile_assumes ~without_ownership_checking sigma prog5 insts) + ^^ pp_label "Constant function tests" constant_tests_defs + ^^ pp_label "Generator-based tests" generator_tests_defs + ^^ pp_label + "Main function" + (string "int main" + ^^ parens (string "int argc, char* argv[]") + ^^ break 1 + ^^ braces + (nest + 2 + (hardline + ^^ separate_map + (twice hardline) + (separate_map hardline (fun test -> + let macro = Test.registration_macro test in + string macro + ^^ parens + (string test.suite ^^ comma ^^ space ^^ string test.test) + ^^ semi)) + tests + ^^ twice hardline + ^^ string "return cn_test_main(argc, argv);") + ^^ hardline)) + ^^ hardline + + +let save ?(perm = 0o666) (output_dir : string) (filename : string) (doc : Pp.document) + : unit + = + let oc = + Stdlib.open_out_gen + [ Open_wronly; Open_creat; Open_trunc; Open_text ] + perm + (Filename.concat output_dir filename) + in + output_string oc (Pp.plain ~width:80 doc); + close_out oc + + +let save_generators + ~output_dir + ~filename_base + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + (insts : Executable_spec_extract.instrumentation list) + : unit + = + let generators_doc = + SpecTests.compile_generators + sigma + prog5 + (List.filter (fun inst -> not (is_constant_function sigma inst)) insts) + in + let generators_fn = filename_base ^ "_gen.h" in + save output_dir generators_fn generators_doc + + +let save_tests + ~output_dir + ~filename_base + ~without_ownership_checking + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + (insts : Executable_spec_extract.instrumentation list) + : string + = + let tests_doc = + compile_test_file ~without_ownership_checking filename_base sigma prog5 insts + in + let test_file = filename_base ^ "_test.c" in + save output_dir test_file tests_doc; + test_file + + +let save_build_script ~output_dir ~test_file = + let script_doc = BuildScript.generate ~output_dir ~test_file in + save ~perm:0o777 output_dir "run_tests.sh" script_doc + + let run ~output_dir ~filename ~without_ownership_checking (cfg : config) - (sigma : Cerb_frontend.GenTypes.genTypeCategory Cerb_frontend.AilSyntax.sigma) + (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) : unit = Config.initialize cfg; - if Option.is_some prog5.main then - failwith "Cannot test a file with a `main` function"; Cerb_debug.begin_csv_timing (); - SpecTests.generate ~output_dir ~filename ~without_ownership_checking sigma prog5; + let insts = prog5 |> Executable_spec_extract.collect_instrumentation |> fst in + let selected_fsyms = + Check.select_functions + (Sym.Set.of_list + (List.map + (fun (inst : Executable_spec_extract.instrumentation) -> inst.fn) + insts)) + in + let insts = + insts + |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> + Option.is_some inst.internal && Sym.Set.mem inst.fn selected_fsyms) + in + let filename_base = filename |> Filename.basename |> Filename.chop_extension in + save_generators ~output_dir ~filename_base sigma prog5 insts; + let test_file = + save_tests ~output_dir ~filename_base ~without_ownership_checking sigma prog5 insts + in + save_build_script ~output_dir ~test_file; Cerb_debug.end_csv_timing "specification test generation" diff --git a/runtime/libcn/include/cn-testing/test.h b/runtime/libcn/include/cn-testing/test.h index a9b60b383..81bb50923 100644 --- a/runtime/libcn/include/cn-testing/test.h +++ b/runtime/libcn/include/cn-testing/test.h @@ -14,40 +14,49 @@ enum cn_test_gen_progress { typedef enum cn_test_result cn_test_case_fn(enum cn_test_gen_progress); -void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func); +void cn_register_test_case(const char* suite, const char* name, cn_test_case_fn* func); -void print_test_info(char* suite, char* name, int tests, int discards); +void print_test_info(const char* suite, const char* name, int tests, int discards); -#define CN_UNIT_TEST_CASE(Name) \ - static jmp_buf buf_##Name; \ + +#define CN_UNIT_TEST_CASE_NAME(FuncName) cn_test_const_##FuncName + +#define CN_UNIT_TEST_CASE(FuncName) \ + static jmp_buf buf_##FuncName; \ \ - void cn_test_##Name##_fail () { \ - longjmp(buf_##Name, 1); \ + void cn_test_const_##FuncName##_fail () { \ + longjmp(buf_##FuncName, 1); \ } \ \ - enum cn_test_result cn_test_##Name () { \ - if (setjmp(buf_##Name)) { \ + enum cn_test_result cn_test_const_##FuncName () { \ + if (setjmp(buf_##FuncName)) { \ return CN_TEST_FAIL; \ } \ - set_cn_failure_cb(&cn_test_##Name##_fail); \ + set_cn_failure_cb(&cn_test_const_##FuncName##_fail); \ \ CN_TEST_INIT(); \ - Name(); \ + FuncName(); \ \ return CN_TEST_PASS; \ } +#define CN_REGISTER_UNIT_TEST_CASE(Suite, FuncName) \ + cn_register_test_case( \ + #Suite, \ + #FuncName, \ + &CN_UNIT_TEST_CASE_NAME(FuncName)); + #define CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Suite, Name, Samples, Init, ...) \ static jmp_buf buf_##Name; \ \ - void cn_test_##Name##_fail (enum cn_failure_mode mode) { \ + void cn_test_gen_##Name##_fail (enum cn_failure_mode mode) { \ longjmp(buf_##Name, mode); \ } \ \ - enum cn_test_result cn_test_##Name (enum cn_test_gen_progress progress_level) { \ + enum cn_test_result cn_test_gen_##Name (enum cn_test_gen_progress progress_level) { \ cn_gen_rand_checkpoint checkpoint = cn_gen_rand_save(); \ int i = 0, d = 0; \ - set_cn_failure_cb(&cn_test_##Name##_fail); \ + set_cn_failure_cb(&cn_test_gen_##Name##_fail); \ switch (setjmp(buf_##Name)) { \ case CN_FAILURE_ASSERT: \ case CN_FAILURE_CHECK_OWNERSHIP: \ @@ -100,12 +109,20 @@ void print_test_info(char* suite, char* name, int tests, int discards); #define CN_RANDOM_TEST_CASE_WITH_INIT(Suite, Name, Samples, ...) \ CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT( \ - Suite, Name, Samples, cn_test_##Name##_init, __VA_ARGS__) + Suite, Name, Samples, cn_test_gen_##Name##_init, __VA_ARGS__) +#define CN_RANDOM_TEST_CASE_NAME(FuncName) cn_test_gen_##FuncName + #define CN_RANDOM_TEST_CASE(Suite, Name, Samples, ...) \ CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Suite, Name, Samples, , __VA_ARGS__) +#define CN_REGISTER_RANDOM_TEST_CASE(Suite, FuncName) \ + cn_register_test_case( \ + #Suite, \ + #FuncName, \ + &CN_RANDOM_TEST_CASE_NAME(FuncName)); + int cn_test_main(int argc, char* argv[]); #define CN_TEST_INIT() \ @@ -117,13 +134,4 @@ int cn_test_main(int argc, char* argv[]); cn_gen_alloc_reset(); \ cn_gen_ownership_reset(); -#define CN_TEST_GENERATE(name) ({ \ - struct cn_gen_##name##_record* res = cn_gen_##name(); \ - if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ - printf("generation failed\n"); \ - return 1; \ - } \ - res; \ -}) - #endif // CN_TEST_H diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index a5b3b95fa..dcc639503 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -15,8 +15,8 @@ #include struct cn_test_case { - char* suite; - char* name; + const char* suite; + const char* name; cn_test_case_fn* func; }; @@ -25,7 +25,7 @@ struct cn_test_case { static struct cn_test_case test_cases[CN_TEST_MAX_TEST_CASES]; static uint16_t num_test_cases = 0; -void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func) { +void cn_register_test_case(const char* suite, const char* name, cn_test_case_fn* func) { if (num_test_cases == CN_TEST_MAX_TEST_CASES) { printf("Tried to register too many tests."); exit(1); @@ -38,7 +38,7 @@ void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func) { }; } -void print_test_info(char* suite, char* name, int tests, int discards) { +void print_test_info(const char* suite, const char* name, int tests, int discards) { if (tests == 0 && discards == 0) { printf("Testing %s::%s:", suite, name); } @@ -62,7 +62,7 @@ int cn_test_main(int argc, char* argv[]) { int interactive = 0; enum cn_logging_level logging_level = CN_LOGGING_ERROR; int timeout = 0; - int input_timeout = 0; + int input_timeout = 5000; int exit_fast = 0; for (int i = 0; i < argc; i++) { char* arg = argv[i]; From 6d4b486239ddc8d3dbdd201d2a319d082ebe2588 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Thu, 2 Jan 2025 16:35:14 -0500 Subject: [PATCH 147/148] [CN-Test-Gen] Expose `static` hack via CLI flag (#808) --- backend/cn/bin/main.ml | 106 ++++++----- backend/cn/lib/testGeneration/buildScript.ml | 79 ++++++-- backend/cn/lib/testGeneration/buildScript.mli | 2 +- backend/cn/lib/testGeneration/specTests.ml | 152 ++++++++------- backend/cn/lib/testGeneration/specTests.mli | 3 +- .../cn/lib/testGeneration/testGenConfig.ml | 6 +- .../cn/lib/testGeneration/testGenConfig.mli | 3 + .../cn/lib/testGeneration/testGeneration.ml | 178 ++++++++++++++---- .../cn/lib/testGeneration/testGeneration.mli | 11 +- tests/run-cn-test-gen.sh | 2 +- 10 files changed, 373 insertions(+), 169 deletions(-) diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index 0ffdb0d56..816fe8743 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -73,7 +73,7 @@ let frontend ~macros ~incl_dirs ~incl_files astprints ~filename ~magic_comment_c idents = [ Alloc.History.(str, sym, None) ] } in - let@ _, ail_prog_opt, prog0 = + let@ cabs_tunit_opt, ail_prog_opt, prog0 = c_frontend_and_elaboration ~cn_init_scope (conf, io) (stdlib, impl) ~filename in let@ () = @@ -83,6 +83,7 @@ let frontend ~macros ~incl_dirs ~incl_files astprints ~filename ~magic_comment_c else return () in + let cabs_tunit = Option.get cabs_tunit_opt in let markers_env, ail_prog = Option.get ail_prog_opt in Tags.set_tagDefs prog0.Core.tagDefs; let prog1 = Remove_unspecs.rewrite_file prog0 in @@ -91,7 +92,7 @@ let frontend ~macros ~incl_dirs ~incl_files astprints ~filename ~magic_comment_c let statement_locs = CStatements.search (snd ail_prog) in print_log_file ("original", CORE prog0); print_log_file ("without_unspec", CORE prog1); - return (prog3, (markers_env, ail_prog), statement_locs) + return (cabs_tunit, prog3, (markers_env, ail_prog), statement_locs) let handle_frontend_error = function @@ -132,6 +133,7 @@ let with_well_formedness_check ~(* Callbacks *) handle_error ~(f : + cabs_tunit:CF.Cabs.translation_unit -> prog5:unit Mucore.file -> ail_prog:CF.GenTypes.genTypeCategory A.ail_program -> statement_locs:Cerb_location.t CStatements.LocMap.t -> @@ -139,7 +141,7 @@ let with_well_formedness_check unit Or_TypeError.t) = check_input_file filename; - let prog, (markers_env, ail_prog), statement_locs = + let cabs_tunit, prog, (markers_env, ail_prog), statement_locs = handle_frontend_error (frontend ~macros @@ -169,7 +171,7 @@ let with_well_formedness_check Typing.run_to_pause Context.empty (Check.check_decls_lemmata_fun_specs prog5) in Result.iter_error handle_error (Typing.pause_to_result paused); - f ~prog5 ~ail_prog ~statement_locs ~paused + f ~cabs_tunit ~prog5 ~ail_prog ~statement_locs ~paused in Pp.maybe_close_times_channel (); Result.fold ~ok:(fun () -> exit 0) ~error:handle_error result @@ -250,7 +252,8 @@ let well_formed ~no_inherit_loc ~magic_comment_char_dollar ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) - ~f:(fun ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused:_ -> Or_TypeError.return ()) + ~f:(fun ~cabs_tunit:_ ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused:_ -> + Or_TypeError.return ()) let verify @@ -321,7 +324,7 @@ let verify ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) - ~f:(fun ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused -> + ~f:(fun ~cabs_tunit:_ ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused -> let check (functions, global_var_constraints, lemmas) = let open Typing in let@ errors = Check.time_check_c_functions (global_var_constraints, functions) in @@ -413,7 +416,7 @@ let generate_executable_specs ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) - ~f:(fun ~prog5 ~ail_prog ~statement_locs ~paused:_ -> + ~f:(fun ~cabs_tunit:_ ~prog5 ~ail_prog ~statement_locs ~paused:_ -> Cerb_colour.without_colour (fun () -> (try @@ -457,6 +460,7 @@ let run_tests max_backtracks max_unfolds max_array_length + with_static_hack input_timeout null_in_every seed @@ -495,25 +499,45 @@ let run_tests ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) ~handle_error - ~f:(fun ~prog5 ~ail_prog ~statement_locs ~paused:_ -> + ~f:(fun ~cabs_tunit ~prog5 ~ail_prog ~statement_locs ~paused:_ -> + let config : TestGeneration.config = + { num_samples; + max_backtracks; + max_unfolds; + max_array_length; + with_static_hack; + input_timeout; + null_in_every; + seed; + logging_level; + progress_level; + interactive; + until_timeout; + exit_fast; + max_stack_depth; + allowed_depth_failures; + max_generator_size; + random_size_splits; + allowed_size_split_backtracks; + sized_null; + coverage; + disable_passes + } + in + TestGeneration.set_config config; + let _, sigma = ail_prog in + if + List.is_empty + (TestGeneration.functions_under_test ~with_warning:true cabs_tunit sigma prog5) + then ( + print_endline "No testable functions, trivially passing"; + exit 0); + if not (Sys.file_exists output_dir) then ( + print_endline ("Directory \"" ^ output_dir ^ "\" does not exist."); + Sys.mkdir output_dir 0o777; + print_endline ("Created directory \"" ^ output_dir ^ "\" with full permissions.")); Cerb_colour.without_colour (fun () -> - if - prog5 - |> Executable_spec_extract.collect_instrumentation - |> fst - |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> - Option.is_some inst.internal) - |> List.is_empty - then ( - print_endline "No testable functions, trivially passing"; - exit 0); - if not (Sys.file_exists output_dir) then ( - print_endline ("Directory \"" ^ output_dir ^ "\" does not exist."); - Sys.mkdir output_dir 0o777; - print_endline - ("Created directory \"" ^ output_dir ^ "\" with full permissions.")); - let _, sigma = ail_prog in Cn_internal_to_ail.augment_record_map (BaseTypes.Record []); (try Executable_spec.main @@ -528,35 +552,12 @@ let run_tests statement_locs with | e -> handle_error_with_user_guidance ~label:"CN-Exec" e); - let config : TestGeneration.config = - { num_samples; - max_backtracks; - max_unfolds; - max_array_length; - input_timeout; - null_in_every; - seed; - logging_level; - progress_level; - interactive; - until_timeout; - exit_fast; - max_stack_depth; - allowed_depth_failures; - max_generator_size; - random_size_splits; - allowed_size_split_backtracks; - sized_null; - coverage; - disable_passes - } - in (try TestGeneration.run ~output_dir ~filename ~without_ownership_checking - config + cabs_tunit sigma prog5 with @@ -949,6 +950,14 @@ module Testing_flags = struct & info [ "max-array-length" ] ~doc) + let with_static_hack = + let doc = + "(HACK) Use an `#include` instead of linking to build testing. Necessary until \ + https://github.com/rems-project/cerberus/issues/784 or equivalent." + in + Arg.(value & flag & info [ "with-static-hack" ] ~doc) + + let input_timeout = let doc = "Timeout for discarding a generation attempt (ms)" in Arg.( @@ -1104,6 +1113,7 @@ let testing_cmd = $ Testing_flags.gen_backtrack_attempts $ Testing_flags.gen_max_unfolds $ Testing_flags.max_array_length + $ Testing_flags.with_static_hack $ Testing_flags.input_timeout $ Testing_flags.null_in_every $ Testing_flags.seed diff --git a/backend/cn/lib/testGeneration/buildScript.ml b/backend/cn/lib/testGeneration/buildScript.ml index 3aec09b0e..97685cc43 100644 --- a/backend/cn/lib/testGeneration/buildScript.ml +++ b/backend/cn/lib/testGeneration/buildScript.ml @@ -41,7 +41,7 @@ let attempt cmd success failure = ^^ string "fi" -let compile ~test_file = +let compile ~filename_base = string "# Compile" ^^ hardline ^^ attempt @@ -52,22 +52,65 @@ let compile ~test_file = "-c"; "\"-I${RUNTIME_PREFIX}/include/\""; "-o"; - "\"./" ^ Filename.chop_extension test_file ^ ".o\""; - "\"./" ^ test_file ^ "\"" + "\"./" ^ filename_base ^ "_test.o\""; + "\"./" ^ filename_base ^ "_test.c\"" ] @ if Config.is_coverage () then [ "--coverage" ] else [])) - "Compiled C files." - "Failed to compile C files in ${TEST_DIR}." + ("Compiled '" ^ filename_base ^ "_test.c'.") + ("Failed to compile '" ^ filename_base ^ "_test.c' in ${TEST_DIR}.") + ^^ (if Config.with_static_hack () then + empty + else + twice hardline + ^^ attempt + (String.concat + " " + ([ "cc"; + "-g"; + "-c"; + "\"-I${RUNTIME_PREFIX}/include/\""; + "-o"; + "\"./" ^ filename_base ^ "-exec.o\""; + "\"./" ^ filename_base ^ "-exec.c\"" + ] + @ + if Config.is_coverage () then + [ "--coverage" ] + else + [])) + ("Compiled '" ^ filename_base ^ "-exec.c'.") + ("Failed to compile '" ^ filename_base ^ "-exec.c' in ${TEST_DIR}.") + ^^ twice hardline + ^^ attempt + (String.concat + " " + ([ "cc"; + "-g"; + "-c"; + "\"-I${RUNTIME_PREFIX}/include/\""; + "-o"; + "\"./cn.o\""; + "\"./cn.c\"" + ] + @ + if Config.is_coverage () then + [ "--coverage" ] + else + [])) + "Compiled 'cn.c'." + "Failed to compile 'cn.c' in ${TEST_DIR}.") ^^ hardline -let link ~test_file = +let link ~filename_base = string "# Link" ^^ hardline + ^^ string "echo" + ^^ twice hardline ^^ attempt (String.concat " " @@ -76,7 +119,13 @@ let link ~test_file = "\"-I${RUNTIME_PREFIX}/include\""; "-o"; "\"./tests.out\""; - Filename.chop_extension test_file ^ ".o"; + (filename_base + ^ "_test.o" + ^ + if Config.with_static_hack () then + "" + else + " " ^ filename_base ^ "-exec.o cn.o"); "\"${RUNTIME_PREFIX}/libcn.a\"" ] @ @@ -157,17 +206,19 @@ let run () = in string "# Run" ^^ hardline + ^^ string "echo" + ^^ twice hardline ^^ cmd ^^ hardline ^^ string "test_exit_code=$? # Save tests exit code for later" ^^ hardline -let coverage ~test_file = +let coverage ~filename_base = string "# Coverage" ^^ hardline ^^ attempt - ("gcov \"" ^ test_file ^ "\"") + ("gcov \"" ^ filename_base ^ "_test.c\"") "Recorded coverage via gcov." "Failed to record coverage." ^^ twice hardline @@ -178,22 +229,22 @@ let coverage ~test_file = ^^ twice hardline ^^ attempt "genhtml --output-directory html \"coverage.info\"" - "Generated HTML report at \\\"${TEST_DIR}/html/\\\"." + "Generated HTML report at '${TEST_DIR}/html/'." "Failed to generate HTML report." ^^ hardline -let generate ~(output_dir : string) ~(test_file : string) : Pp.document = +let generate ~(output_dir : string) ~(filename_base : string) : Pp.document = setup ~output_dir ^^ hardline - ^^ compile ~test_file + ^^ compile ~filename_base ^^ hardline - ^^ link ~test_file + ^^ link ~filename_base ^^ hardline ^^ run () ^^ hardline ^^ (if Config.is_coverage () then - coverage ~test_file ^^ hardline + coverage ~filename_base ^^ hardline else empty) ^^ string "popd > /dev/null" diff --git a/backend/cn/lib/testGeneration/buildScript.mli b/backend/cn/lib/testGeneration/buildScript.mli index 45de35f3d..9d2928de2 100644 --- a/backend/cn/lib/testGeneration/buildScript.mli +++ b/backend/cn/lib/testGeneration/buildScript.mli @@ -1 +1 @@ -val generate : output_dir:string -> test_file:string -> Pp.document +val generate : output_dir:string -> filename_base:string -> Pp.document diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index d261bb501..963445f79 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -31,7 +31,9 @@ let debug_stage (stage : string) (str : string) : unit = debug_log (str ^ "\n\n") -let compile_constant_tests (insts : Executable_spec_extract.instrumentation list) +let compile_constant_tests + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (insts : Executable_spec_extract.instrumentation list) : Test.t list * Pp.document = let test_names, docs = @@ -48,18 +50,29 @@ let compile_constant_tests (insts : Executable_spec_extract.instrumentation list |> List.hd; test = Sym.pp_string inst.fn }, - CF.Pp_ail.pp_statement - A.( - Utils.mk_stmt - (AilSexpr - (Utils.mk_expr - (AilEcall - ( Utils.mk_expr (AilEident (Sym.fresh_named "CN_UNIT_TEST_CASE")), - [ Utils.mk_expr (AilEident inst.fn) ] ))))) )) + let open Pp in + (if not (Config.with_static_hack ()) then + CF.Pp_ail.pp_function_prototype + ~executable_spec:true + inst.fn + (let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in + decl) + ^^ hardline + else + empty) + ^^ CF.Pp_ail.pp_statement + A.( + Utils.mk_stmt + (AilSexpr + (Utils.mk_expr + (AilEcall + ( Utils.mk_expr + (AilEident (Sym.fresh_named "CN_UNIT_TEST_CASE")), + [ Utils.mk_expr (AilEident inst.fn) ] ))))) )) insts in let open Pp in - (test_names, separate (semi ^^ twice hardline) docs ^^ twice hardline) + (test_names, separate (twice hardline) docs ^^ twice hardline) let compile_generators @@ -84,6 +97,7 @@ let compile_generators let compile_random_test_case + (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) (args_map : (Sym.t * (Sym.t * C.ctype) list) list) (convert_from : Sym.t * C.ctype -> Pp.document) @@ -112,59 +126,68 @@ let compile_random_test_case | GlobalDef (sct, _) -> (sym, sct)) global_syms in - (if List.is_empty globals then - string "CN_RANDOM_TEST_CASE" - else ( - let init_name = string "cn_test_gen_" ^^ Sym.pp inst.fn ^^ string "_init" in - string "void" - ^^ space - ^^ init_name - ^^ parens - (string "struct" - ^^ space - ^^ string (String.concat "_" [ "cn_gen"; Sym.pp_string inst.fn; "record" ]) - ^^ star - ^^ space - ^^ string "res") - ^^ space - ^^ braces - (nest - 2 - (hardline - ^^ separate_map - hardline - (fun (sym, sct) -> - let ty = - CF.Pp_ail.pp_ctype - ~executable_spec:true - ~is_human:false - C.no_qualifiers - (Sctypes.to_ctype sct) - in - Sym.pp sym - ^^ space - ^^ equals - ^^ space - ^^ star - ^^ parens (ty ^^ star) - ^^ string "convert_from_cn_pointer" - ^^ parens - (string "res->" ^^ Sym.pp (GenUtils.get_mangled_name [ sym ])) - ^^ semi - ^^ hardline - ^^ string "cn_assume_ownership" - ^^ parens - (separate - (comma ^^ space) - [ ampersand ^^ Sym.pp sym; - string "sizeof" ^^ parens ty; - string "(char*)" ^^ dquotes init_name - ]) - ^^ semi) - globals) - ^^ hardline) - ^^ twice hardline - ^^ string "CN_RANDOM_TEST_CASE_WITH_INIT")) + (if not (Config.with_static_hack ()) then + CF.Pp_ail.pp_function_prototype + ~executable_spec:true + inst.fn + (let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in + decl) + ^^ hardline + else + empty) + ^^ (if List.is_empty globals then + string "CN_RANDOM_TEST_CASE" + else ( + let init_name = string "cn_test_gen_" ^^ Sym.pp inst.fn ^^ string "_init" in + string "void" + ^^ space + ^^ init_name + ^^ parens + (string "struct" + ^^ space + ^^ string (String.concat "_" [ "cn_gen"; Sym.pp_string inst.fn; "record" ]) + ^^ star + ^^ space + ^^ string "res") + ^^ space + ^^ braces + (nest + 2 + (hardline + ^^ separate_map + hardline + (fun (sym, sct) -> + let ty = + CF.Pp_ail.pp_ctype + ~executable_spec:true + ~is_human:false + C.no_qualifiers + (Sctypes.to_ctype sct) + in + Sym.pp sym + ^^ space + ^^ equals + ^^ space + ^^ star + ^^ parens (ty ^^ star) + ^^ string "convert_from_cn_pointer" + ^^ parens + (string "res->" ^^ Sym.pp (GenUtils.get_mangled_name [ sym ])) + ^^ semi + ^^ hardline + ^^ string "cn_assume_ownership" + ^^ parens + (separate + (comma ^^ space) + [ ampersand ^^ Sym.pp sym; + string "sizeof" ^^ parens ty; + string "(char*)" ^^ dquotes init_name + ]) + ^^ semi) + globals) + ^^ hardline) + ^^ twice hardline + ^^ string "CN_RANDOM_TEST_CASE_WITH_INIT")) ^^ parens (separate (comma ^^ space) @@ -173,6 +196,7 @@ let compile_random_test_case int (Config.get_num_samples ()); separate_map (comma ^^ space) convert_from args ]) + ^^ semi ^^ twice hardline @@ -237,5 +261,5 @@ let compile_generator_tests let open Pp in ( tests, concat_map - (compile_random_test_case prog5 args_map convert_from) + (compile_random_test_case sigma prog5 args_map convert_from) (List.combine tests insts) ) diff --git a/backend/cn/lib/testGeneration/specTests.mli b/backend/cn/lib/testGeneration/specTests.mli index 6e9915cdb..b64eb23c1 100644 --- a/backend/cn/lib/testGeneration/specTests.mli +++ b/backend/cn/lib/testGeneration/specTests.mli @@ -2,7 +2,8 @@ module CF = Cerb_frontend module A = CF.AilSyntax val compile_constant_tests - : Executable_spec_extract.instrumentation list -> + : CF.GenTypes.genTypeCategory A.sigma -> + Executable_spec_extract.instrumentation list -> Test.t list * Pp.document val compile_generators diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index 6c0746240..8a43a1223 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -4,8 +4,9 @@ type t = max_backtracks : int; max_unfolds : int option; max_array_length : int; - input_timeout : int option; + with_static_hack : bool; (* Run time *) + input_timeout : int option; null_in_every : int option; seed : string option; logging_level : int option; @@ -28,6 +29,7 @@ let default = max_backtracks = 25; max_unfolds = None; max_array_length = 50; + with_static_hack = false; input_timeout = None; null_in_every = None; seed = None; @@ -59,6 +61,8 @@ let get_max_unfolds () = !instance.max_unfolds let get_max_array_length () = !instance.max_array_length +let with_static_hack () = !instance.with_static_hack + let has_input_timeout () = !instance.input_timeout let has_null_in_every () = !instance.null_in_every diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index b5dd0a8d2..e1c9acbce 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -4,6 +4,7 @@ type t = max_backtracks : int; max_unfolds : int option; max_array_length : int; + with_static_hack : bool; (* Run time *) input_timeout : int option; null_in_every : int option; @@ -35,6 +36,8 @@ val get_max_unfolds : unit -> int option val get_max_array_length : unit -> int +val with_static_hack : unit -> bool + val has_input_timeout : unit -> int option val has_null_in_every : unit -> int option diff --git a/backend/cn/lib/testGeneration/testGeneration.ml b/backend/cn/lib/testGeneration/testGeneration.ml index 4f994b3a1..52837d782 100644 --- a/backend/cn/lib/testGeneration/testGeneration.ml +++ b/backend/cn/lib/testGeneration/testGeneration.ml @@ -11,6 +11,8 @@ type config = Config.t let default_cfg : config = Config.default +let set_config = Config.initialize + let is_constant_function (sigma : CF.GenTypes.genTypeCategory A.sigma) (inst : Executable_spec_extract.instrumentation) @@ -92,6 +94,28 @@ let pp_label ?(width : int = 30) (label : string) (doc : Pp.document) : Pp.docum ^^ doc +let compile_includes ~filename_base = + let open Pp in + string "#include " + ^^ dquotes (string (filename_base ^ "_gen.h")) + ^^ hardline + ^^ + if Config.with_static_hack () then + string "#include " + ^^ dquotes (string (filename_base ^ "-exec.c")) + ^^ hardline + ^^ string "#include " + ^^ dquotes (string "cn.c") + else + string "#include " ^^ dquotes (string "cn.h") + + +let compile_test test = + let open Pp in + let macro = Test.registration_macro test in + string macro ^^ parens (string test.suite ^^ comma ^^ space ^^ string test.test) ^^ semi + + let compile_test_file ~(without_ownership_checking : bool) (filename_base : string) @@ -101,21 +125,14 @@ let compile_test_file = let for_constant, for_generator = List.partition (is_constant_function sigma) insts in let constant_tests, constant_tests_defs = - SpecTests.compile_constant_tests for_constant + SpecTests.compile_constant_tests sigma for_constant in let generator_tests, generator_tests_defs = SpecTests.compile_generator_tests sigma prog5 for_generator in let tests = [ constant_tests; generator_tests ] in let open Pp in - string "#include " - ^^ dquotes (string (filename_base ^ "_gen.h")) - ^^ hardline - ^^ string "#include " - ^^ dquotes (string (filename_base ^ "-exec.c")) - ^^ hardline - ^^ string "#include " - ^^ dquotes (string "cn.c") + compile_includes ~filename_base ^^ twice hardline ^^ pp_label "Assume Ownership Functions" @@ -133,12 +150,7 @@ let compile_test_file (hardline ^^ separate_map (twice hardline) - (separate_map hardline (fun test -> - let macro = Test.registration_macro test in - string macro - ^^ parens - (string test.suite ^^ comma ^^ space ^^ string test.test) - ^^ semi)) + (separate_map hardline compile_test) tests ^^ twice hardline ^^ string "return cn_test_main(argc, argv);") @@ -184,32 +196,110 @@ let save_tests (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) (insts : Executable_spec_extract.instrumentation list) - : string + : unit = let tests_doc = compile_test_file ~without_ownership_checking filename_base sigma prog5 insts in - let test_file = filename_base ^ "_test.c" in - save output_dir test_file tests_doc; - test_file + save output_dir (filename_base ^ "_test.c") tests_doc -let save_build_script ~output_dir ~test_file = - let script_doc = BuildScript.generate ~output_dir ~test_file in +let save_build_script ~output_dir ~filename_base = + let script_doc = BuildScript.generate ~output_dir ~filename_base in save ~perm:0o777 output_dir "run_tests.sh" script_doc -let run - ~output_dir - ~filename - ~without_ownership_checking - (cfg : config) +let needs_static_hack + ~(with_warning : bool) + (cabs_tunit : CF.Cabs.translation_unit) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (inst : Executable_spec_extract.instrumentation) + = + let (TUnit decls) = cabs_tunit in + let is_static_func () = + List.exists + (fun decl -> + match decl with + | CF.Cabs.EDecl_func + (FunDef + ( loc, + _, + { storage_classes; _ }, + Declarator + (_, DDecl_function (DDecl_identifier (_, Identifier (_, fn')), _)), + _ )) + when String.equal (Sym.pp_string inst.fn) fn' + && List.exists + (fun scs -> match scs with CF.Cabs.SC_static -> true | _ -> false) + storage_classes -> + if with_warning then + Cerb_colour.with_colour + (fun () -> + Pp.( + warn + loc + (string "Static function" + ^^^ squotes (Sym.pp inst.fn) + ^^^ string "could not be tested." + ^/^ string "You can try again with '--with-static-hack'"))) + (); + true + | _ -> false) + decls + in + let _, _, _, args, _ = List.assoc Sym.equal inst.fn sigma.function_definitions in + let depends_on_static_glob () = + let global_syms = + inst.internal + |> Option.get + |> AT.get_lat + |> LAT.free_vars (fun _ -> Sym.Set.empty) + |> Sym.Set.to_seq + |> List.of_seq + |> List.filter (fun x -> + not + (List.mem (fun x y -> String.equal (Sym.pp_string x) (Sym.pp_string y)) x args)) + in + let static_globs = + List.filter_map + (fun sym -> + match List.assoc Sym.equal sym sigma.declarations with + | loc, _, Decl_object ((Static, _), _, _, _) -> Some (sym, loc) + | _ -> None) + global_syms + in + if List.is_empty static_globs then + false + else ( + if with_warning then + Cerb_colour.with_colour + (fun () -> + List.iter + (fun (sym, loc) -> + Pp.( + warn + loc + (string "Function" + ^^^ squotes (Sym.pp inst.fn) + ^^^ string "relies on static global" + ^^^ squotes (Sym.pp sym) + ^^ comma + ^^^ string "so could not be tested." + ^^^ string "You can try again with '--with-static-hack'."))) + static_globs) + (); + true) + in + is_static_func () || depends_on_static_glob () + + +let functions_under_test + ~(with_warning : bool) + (cabs_tunit : CF.Cabs.translation_unit) (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) - : unit + : Executable_spec_extract.instrumentation list = - Config.initialize cfg; - Cerb_debug.begin_csv_timing (); let insts = prog5 |> Executable_spec_extract.collect_instrumentation |> fst in let selected_fsyms = Check.select_functions @@ -218,15 +308,27 @@ let run (fun (inst : Executable_spec_extract.instrumentation) -> inst.fn) insts)) in - let insts = - insts - |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> - Option.is_some inst.internal && Sym.Set.mem inst.fn selected_fsyms) - in + insts + |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> + Option.is_some inst.internal + && Sym.Set.mem inst.fn selected_fsyms + && (Config.with_static_hack () + || not (needs_static_hack ~with_warning cabs_tunit sigma inst))) + + +let run + ~output_dir + ~filename + ~without_ownership_checking + (cabs_tunit : CF.Cabs.translation_unit) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + : unit + = + Cerb_debug.begin_csv_timing (); + let insts = functions_under_test ~with_warning:false cabs_tunit sigma prog5 in let filename_base = filename |> Filename.basename |> Filename.chop_extension in save_generators ~output_dir ~filename_base sigma prog5 insts; - let test_file = - save_tests ~output_dir ~filename_base ~without_ownership_checking sigma prog5 insts - in - save_build_script ~output_dir ~test_file; + save_tests ~output_dir ~filename_base ~without_ownership_checking sigma prog5 insts; + save_build_script ~output_dir ~filename_base; Cerb_debug.end_csv_timing "specification test generation" diff --git a/backend/cn/lib/testGeneration/testGeneration.mli b/backend/cn/lib/testGeneration/testGeneration.mli index d20712e81..2e7b60dea 100644 --- a/backend/cn/lib/testGeneration/testGeneration.mli +++ b/backend/cn/lib/testGeneration/testGeneration.mli @@ -2,11 +2,20 @@ type config = TestGenConfig.t val default_cfg : config +val set_config : config -> unit + +val functions_under_test + : with_warning:bool -> + Cerb_frontend.Cabs.translation_unit -> + Cerb_frontend.GenTypes.genTypeCategory Cerb_frontend.AilSyntax.sigma -> + unit Mucore.file -> + Executable_spec_extract.instrumentation list + val run : output_dir:string -> filename:string -> without_ownership_checking:bool -> - config -> + Cerb_frontend.Cabs.translation_unit -> Cerb_frontend.GenTypes.genTypeCategory Cerb_frontend.AilSyntax.sigma -> unit Mucore.file -> unit diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index 2524271f0..bfb477a1e 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -27,7 +27,7 @@ function separator() { printf '\n\n' } -CONFIGS=("--coverage" "--sized-null" "--random-size-splits" "--random-size-splits --allowed-size-split-backtracks=10") +CONFIGS=("--coverage" "--with-static-hack --coverage" "--sized-null" "--random-size-splits" "--random-size-splits --allowed-size-split-backtracks=10") # For each configuration for CONFIG in "${CONFIGS[@]}"; do From 6316f8f46dd8d6b207b8669c6ec082f78032e538 Mon Sep 17 00:00:00 2001 From: Zain K Aamer Date: Fri, 3 Jan 2025 01:22:03 -0500 Subject: [PATCH 148/148] [CN-Test-Gen] Enum hints for `--with-static-hack` (#812) --- .../cn/lib/testGeneration/testGeneration.ml | 54 +++++++++++++++++-- tests/cn-test-gen/src/enum1.pass.c | 7 +++ tests/cn-test-gen/src/enum2.pass.c | 7 +++ 3 files changed, 65 insertions(+), 3 deletions(-) create mode 100644 tests/cn-test-gen/src/enum1.pass.c create mode 100644 tests/cn-test-gen/src/enum2.pass.c diff --git a/backend/cn/lib/testGeneration/testGeneration.ml b/backend/cn/lib/testGeneration/testGeneration.ml index 52837d782..abe4ac061 100644 --- a/backend/cn/lib/testGeneration/testGeneration.ml +++ b/backend/cn/lib/testGeneration/testGeneration.ml @@ -209,6 +209,7 @@ let save_build_script ~output_dir ~filename_base = save ~perm:0o777 output_dir "run_tests.sh" script_doc +(** Workaround for https://github.com/rems-project/cerberus/issues/784 *) let needs_static_hack ~(with_warning : bool) (cabs_tunit : CF.Cabs.translation_unit) @@ -241,7 +242,7 @@ let needs_static_hack (string "Static function" ^^^ squotes (Sym.pp inst.fn) ^^^ string "could not be tested." - ^/^ string "You can try again with '--with-static-hack'"))) + ^/^ string "Try again with '--with-static-hack'"))) (); true | _ -> false) @@ -285,7 +286,7 @@ let needs_static_hack ^^^ squotes (Sym.pp sym) ^^ comma ^^^ string "so could not be tested." - ^^^ string "You can try again with '--with-static-hack'."))) + ^^^ string "Try again with '--with-static-hack'."))) static_globs) (); true) @@ -293,6 +294,51 @@ let needs_static_hack is_static_func () || depends_on_static_glob () +(** Workaround for https://github.com/rems-project/cerberus/issues/765 *) +let needs_enum_hack + ~(with_warning : bool) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (inst : Executable_spec_extract.instrumentation) + = + match List.assoc Sym.equal inst.fn sigma.declarations with + | loc, _, Decl_function (_, (_, ret_ct), cts, _, _, _) -> + if + List.exists + (fun (_, ct, _) -> + match ct with C.Ctype (_, Basic (Integer (Enum _))) -> true | _ -> false) + cts + then ( + if with_warning then + Cerb_colour.with_colour + (fun () -> + Pp.( + warn + loc + (string "Function" + ^^^ squotes (Sym.pp inst.fn) + ^^^ string "has enum arguments and so could not be tested." + ^/^ string "Try again with '--with-static-hack'"))) + (); + true) + else if match ret_ct with C.Ctype (_, Basic (Integer (Enum _))) -> true | _ -> false + then ( + if with_warning then + Cerb_colour.with_colour + (fun () -> + Pp.( + warn + loc + (string "Function" + ^^^ squotes (Sym.pp inst.fn) + ^^^ string "has an enum return type and so could not be tested." + ^/^ string "Try again with '--with-static-hack'"))) + (); + true) + else + false + | _ -> false + + let functions_under_test ~(with_warning : bool) (cabs_tunit : CF.Cabs.translation_unit) @@ -313,7 +359,9 @@ let functions_under_test Option.is_some inst.internal && Sym.Set.mem inst.fn selected_fsyms && (Config.with_static_hack () - || not (needs_static_hack ~with_warning cabs_tunit sigma inst))) + || not + (needs_static_hack ~with_warning cabs_tunit sigma inst + || needs_enum_hack ~with_warning sigma inst))) let run diff --git a/tests/cn-test-gen/src/enum1.pass.c b/tests/cn-test-gen/src/enum1.pass.c new file mode 100644 index 000000000..df29512a3 --- /dev/null +++ b/tests/cn-test-gen/src/enum1.pass.c @@ -0,0 +1,7 @@ +enum color { + Red, Green, Blue +}; + +enum color identity(enum color x) { + return x; +} diff --git a/tests/cn-test-gen/src/enum2.pass.c b/tests/cn-test-gen/src/enum2.pass.c new file mode 100644 index 000000000..d0a54e46d --- /dev/null +++ b/tests/cn-test-gen/src/enum2.pass.c @@ -0,0 +1,7 @@ +enum color { + Red, Green, Blue +}; + +enum color identity() { + return Red; +}