From ba61ed50e7b2fdc78690de92d734a3747029f903 Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Wed, 8 Jun 2022 12:32:14 +0200 Subject: read globals from LLBC JSON into functions --- src/Contexts.ml | 1 + src/Expressions.ml | 2 + src/ExtractToFStar.ml | 1 + src/FunIdentifier.ml | 2 + src/FunsAnalysis.ml | 1 + src/Interpreter.ml | 5 +- src/InterpreterStatements.ml | 7 ++- src/LlbcAst.ml | 5 +- src/LlbcAstUtils.ml | 1 + src/LlbcOfJson.ml | 146 ++++++++++++++++++++++++++++++------------- src/Modules.ml | 1 + src/Print.ml | 13 ++-- src/PrintPure.ml | 6 +- src/PrintSymbolicAst.ml | 3 +- src/Pure.ml | 2 +- src/PureToExtract.ml | 1 + src/SymbolicToPure.ml | 1 + src/Translate.ml | 21 ++++--- src/TranslateCore.ml | 9 +-- src/TypesUtils.ml | 13 ++-- 20 files changed, 161 insertions(+), 80 deletions(-) create mode 100644 src/FunIdentifier.ml (limited to 'src') diff --git a/src/Contexts.ml b/src/Contexts.ml index a4551420..bbf5b8f3 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -1,6 +1,7 @@ open Types open Values open LlbcAst +open FunIdentifier module V = Values open ValuesUtils module M = Modules diff --git a/src/Expressions.ml b/src/Expressions.ml index 6bf14c66..f1a4a8c3 100644 --- a/src/Expressions.ml +++ b/src/Expressions.ml @@ -1,5 +1,6 @@ open Types open Values +open FunIdentifier type field_proj_kind = | ProjAdt of TypeDeclId.id * VariantId.id option @@ -88,6 +89,7 @@ let all_binops = *) type operand_constant_value = | ConstantValue of constant_value + | ConstantId of FunDeclId.id | ConstantAdt of VariantId.id option * operand_constant_value list [@@deriving show] diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 0bbe591e..9766ddaf 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -6,6 +6,7 @@ open PureUtils open TranslateCore open PureToExtract open StringUtils +open FunIdentifier module F = Format (** A qualifier for a type definition. diff --git a/src/FunIdentifier.ml b/src/FunIdentifier.ml new file mode 100644 index 00000000..dd7e9318 --- /dev/null +++ b/src/FunIdentifier.ml @@ -0,0 +1,2 @@ +open Identifiers +module FunDeclId = IdGen () diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index dc205eb9..cf2e0bd6 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -9,6 +9,7 @@ open LlbcAst open Modules +open FunIdentifier type fun_info = { can_fail : bool; diff --git a/src/Interpreter.ml b/src/Interpreter.ml index f6ae268d..702aeea6 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -1,4 +1,5 @@ open Cps +open FunIdentifier open InterpreterUtils open InterpreterProjectors open InterpreterBorrows @@ -255,9 +256,9 @@ module Test = struct environment. *) let test_unit_function (config : C.partial_config) (m : M.llbc_module) - (fid : A.FunDeclId.id) : unit = + (fid : FunDeclId.id) : unit = (* Retrieve the function declaration *) - let fdef = A.FunDeclId.nth m.functions fid in + let fdef = FunDeclId.nth m.functions fid in let body = Option.get fdef.body in (* Debug *) diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 1083d643..c7308720 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -7,6 +7,7 @@ module A = LlbcAst module L = Logging open TypesUtils open ValuesUtils +open FunIdentifier module Inv = Invariants module S = SynthesizeSymbolic open Errors @@ -1001,7 +1002,7 @@ and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = call.args call.dest (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) +and eval_local_function_call_concrete (config : C.config) (fid : FunDeclId.id) (region_args : T.erased_region list) (type_args : T.ety list) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> @@ -1079,7 +1080,7 @@ and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_local_function_call_symbolic (config : C.config) (fid : A.FunDeclId.id) +and eval_local_function_call_symbolic (config : C.config) (fid : FunDeclId.id) (region_args : T.erased_region list) (type_args : T.ety list) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> @@ -1300,7 +1301,7 @@ and eval_non_local_function_call (config : C.config) (fid : A.assumed_fun_id) (** Evaluate a local (i.e, not assumed) function call (auxiliary helper for [eval_statement]) *) -and eval_local_function_call (config : C.config) (fid : A.FunDeclId.id) +and eval_local_function_call (config : C.config) (fid : FunDeclId.id) (region_args : T.erased_region list) (type_args : T.ety list) (args : E.operand list) (dest : E.place) : st_cm_fun = match config.mode with diff --git a/src/LlbcAst.ml b/src/LlbcAst.ml index d35cd5d8..4324586d 100644 --- a/src/LlbcAst.ml +++ b/src/LlbcAst.ml @@ -1,10 +1,8 @@ -open Identifiers open Names open Types open Values open Expressions - -module FunDeclId = IdGen () +open FunIdentifier type var = { index : VarId.id; (** Unique variable identifier *) @@ -178,5 +176,6 @@ type fun_decl = { name : fun_name; signature : fun_sig; body : fun_body option; + is_global : bool; } [@@deriving show] diff --git a/src/LlbcAstUtils.ml b/src/LlbcAstUtils.ml index 84e8e00f..bc4236cf 100644 --- a/src/LlbcAstUtils.ml +++ b/src/LlbcAstUtils.ml @@ -1,5 +1,6 @@ open LlbcAst open Utils +open FunIdentifier module T = Types (** Check if a [statement] contains loops *) diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml index 99d652ec..14333088 100644 --- a/src/LlbcOfJson.ml +++ b/src/LlbcOfJson.ml @@ -11,12 +11,14 @@ open Yojson.Basic open Names open OfJsonBasic +open FunIdentifier module T = Types module V = Values module S = Scalars module M = Modules module E = Expressions module A = LlbcAst +module TU = TypesUtils (* The default logger *) let log = Logging.llbc_of_json_logger @@ -225,6 +227,14 @@ let type_decl_of_json (js : json) : (T.type_decl, string) result = } | _ -> Error "") +(* Converts a global ID to its corresponding function ID. + To do so, it adds the global ID to the number of function declarations. +*) +let global_id_of_json (js: json) (fun_count: int) : (FunDeclId.id, string) result = + combine_error_msgs js "global_id_of_json" + (let* gid = FunDeclId.id_of_json js in + Ok (FunDeclId.of_int ((FunDeclId.to_int gid) + fun_count))) + let var_of_json (js : json) : (A.var, string) result = combine_error_msgs js "var_of_json" (match js with @@ -393,7 +403,7 @@ let binop_of_json (js : json) : (E.binop, string) result = | `String "Shr" -> Ok E.Shr | _ -> Error ("binop_of_json failed on:" ^ show js) -let rec operand_constant_value_of_json (js : json) : +let rec operand_constant_value_of_json (js : json) (fun_count : int) : (E.operand_constant_value, string) result = combine_error_msgs js "operand_constant_value_of_json" (match js with @@ -403,12 +413,15 @@ let rec operand_constant_value_of_json (js : json) : | `Assoc [ ("ConstantAdt", `List [ variant_id; field_values ]) ] -> let* variant_id = option_of_json T.VariantId.id_of_json variant_id in let* field_values = - list_of_json operand_constant_value_of_json field_values + list_of_json (fun js -> operand_constant_value_of_json js fun_count) field_values in Ok (E.ConstantAdt (variant_id, field_values)) + | `Assoc [ ("ConstantIdentifier", `List [gid]) ] -> + let* id = global_id_of_json gid fun_count in + Ok (E.ConstantId id) | _ -> Error "") -let operand_of_json (js : json) : (E.operand, string) result = +let operand_of_json (js : json) (fun_count : int) : (E.operand, string) result = combine_error_msgs js "operand_of_json" (match js with | `Assoc [ ("Copy", place) ] -> @@ -417,9 +430,9 @@ let operand_of_json (js : json) : (E.operand, string) result = | `Assoc [ ("Move", place) ] -> let* place = place_of_json place in Ok (E.Move place) - | `Assoc [ ("Constant", `List [ ty; cv ]) ] -> + | `Assoc [ ("Const", `List [ ty; cv ]) ] -> let* ty = ety_of_json ty in - let* cv = operand_constant_value_of_json cv in + let* cv = operand_constant_value_of_json cv fun_count in Ok (E.Constant (ty, cv)) | _ -> Error "") @@ -442,11 +455,11 @@ let aggregate_kind_of_json (js : json) : (E.aggregate_kind, string) result = Ok (E.AggregatedAdt (id, opt_variant_id, regions, tys)) | _ -> Error "") -let rvalue_of_json (js : json) : (E.rvalue, string) result = +let rvalue_of_json (js : json) (fun_count : int) : (E.rvalue, string) result = combine_error_msgs js "rvalue_of_json" (match js with | `Assoc [ ("Use", op) ] -> - let* op = operand_of_json op in + let* op = operand_of_json op fun_count in Ok (E.Use op) | `Assoc [ ("Ref", `List [ place; borrow_kind ]) ] -> let* place = place_of_json place in @@ -454,19 +467,19 @@ let rvalue_of_json (js : json) : (E.rvalue, string) result = Ok (E.Ref (place, borrow_kind)) | `Assoc [ ("UnaryOp", `List [ unop; op ]) ] -> let* unop = unop_of_json unop in - let* op = operand_of_json op in + let* op = operand_of_json op fun_count in Ok (E.UnaryOp (unop, op)) | `Assoc [ ("BinaryOp", `List [ binop; op1; op2 ]) ] -> let* binop = binop_of_json binop in - let* op1 = operand_of_json op1 in - let* op2 = operand_of_json op2 in + let* op1 = operand_of_json op1 fun_count in + let* op2 = operand_of_json op2 fun_count in Ok (E.BinaryOp (binop, op1, op2)) | `Assoc [ ("Discriminant", place) ] -> let* place = place_of_json place in Ok (E.Discriminant place) | `Assoc [ ("Aggregate", `List [ aggregate_kind; ops ]) ] -> let* aggregate_kind = aggregate_kind_of_json aggregate_kind in - let* ops = list_of_json operand_of_json ops in + let* ops = list_of_json (fun js -> operand_of_json js fun_count) ops in Ok (E.Aggregate (aggregate_kind, ops)) | _ -> Error "") @@ -489,18 +502,18 @@ let fun_id_of_json (js : json) : (A.fun_id, string) result = combine_error_msgs js "fun_id_of_json" (match js with | `Assoc [ ("Regular", id) ] -> - let* id = A.FunDeclId.id_of_json id in + let* id = FunDeclId.id_of_json id in Ok (A.Regular id) | `Assoc [ ("Assumed", fid) ] -> let* fid = assumed_fun_id_of_json fid in Ok (A.Assumed fid) | _ -> Error "") -let assertion_of_json (js : json) : (A.assertion, string) result = +let assertion_of_json (js : json) (fun_count : int) : (A.assertion, string) result = combine_error_msgs js "assertion_of_json" (match js with | `Assoc [ ("cond", cond); ("expected", expected) ] -> - let* cond = operand_of_json cond in + let* cond = operand_of_json cond fun_count in let* expected = bool_of_json expected in Ok { A.cond; expected } | _ -> Error "") @@ -534,7 +547,7 @@ let fun_sig_of_json (js : json) : (A.fun_sig, string) result = } | _ -> Error "") -let call_of_json (js : json) : (A.call, string) result = +let call_of_json (js : json) (fun_count : int) : (A.call, string) result = combine_error_msgs js "call_of_json" (match js with | `Assoc @@ -548,17 +561,17 @@ let call_of_json (js : json) : (A.call, string) result = let* func = fun_id_of_json func in let* region_args = list_of_json erased_region_of_json region_args in let* type_args = list_of_json ety_of_json type_args in - let* args = list_of_json operand_of_json args in + let* args = list_of_json (fun js -> operand_of_json js fun_count) args in let* dest = place_of_json dest in Ok { A.func; region_args; type_args; args; dest } | _ -> Error "") -let rec statement_of_json (js : json) : (A.statement, string) result = +let rec statement_of_json (js : json) (fun_count : int) : (A.statement, string) result = combine_error_msgs js "statement_of_json" (match js with | `Assoc [ ("Assign", `List [ place; rvalue ]) ] -> let* place = place_of_json place in - let* rvalue = rvalue_of_json rvalue in + let* rvalue = rvalue_of_json rvalue fun_count in Ok (A.Assign (place, rvalue)) | `Assoc [ ("FakeRead", place) ] -> let* place = place_of_json place in @@ -571,10 +584,10 @@ let rec statement_of_json (js : json) : (A.statement, string) result = let* place = place_of_json place in Ok (A.Drop place) | `Assoc [ ("Assert", assertion) ] -> - let* assertion = assertion_of_json assertion in + let* assertion = assertion_of_json assertion fun_count in Ok (A.Assert assertion) | `Assoc [ ("Call", call) ] -> - let* call = call_of_json call in + let* call = call_of_json call fun_count in Ok (A.Call call) | `String "Panic" -> Ok A.Panic | `String "Return" -> Ok A.Return @@ -586,47 +599,48 @@ let rec statement_of_json (js : json) : (A.statement, string) result = Ok (A.Continue i) | `String "Nop" -> Ok A.Nop | `Assoc [ ("Sequence", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json st1 in - let* st2 = statement_of_json st2 in + let* st1 = statement_of_json st1 fun_count in + let* st2 = statement_of_json st2 fun_count in Ok (A.Sequence (st1, st2)) | `Assoc [ ("Switch", `List [ op; tgt ]) ] -> - let* op = operand_of_json op in - let* tgt = switch_targets_of_json tgt in + let* op = operand_of_json op fun_count in + let* tgt = switch_targets_of_json tgt fun_count in Ok (A.Switch (op, tgt)) | `Assoc [ ("Loop", st) ] -> - let* st = statement_of_json st in + let* st = statement_of_json st fun_count in Ok (A.Loop st) | _ -> Error "") -and switch_targets_of_json (js : json) : (A.switch_targets, string) result = +and switch_targets_of_json (js : json) (fun_count : int) : (A.switch_targets, string) result = combine_error_msgs js "switch_targets_of_json" (match js with | `Assoc [ ("If", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json st1 in - let* st2 = statement_of_json st2 in + let* st1 = statement_of_json st1 fun_count in + let* st2 = statement_of_json st2 fun_count in Ok (A.If (st1, st2)) | `Assoc [ ("SwitchInt", `List [ int_ty; tgts; otherwise ]) ] -> let* int_ty = integer_type_of_json int_ty in let* tgts = - list_of_json - (pair_of_json (list_of_json scalar_value_of_json) statement_of_json) + list_of_json (pair_of_json + (list_of_json scalar_value_of_json) + (fun js -> statement_of_json js fun_count)) tgts in - let* otherwise = statement_of_json otherwise in + let* otherwise = statement_of_json otherwise fun_count in Ok (A.SwitchInt (int_ty, tgts, otherwise)) | _ -> Error "") -let fun_body_of_json (js : json) : (A.fun_body, string) result = +let fun_body_of_json (js : json) (fun_count : int) : (A.fun_body, string) result = combine_error_msgs js "fun_body_of_json" (match js with | `Assoc [ ("arg_count", arg_count); ("locals", locals); ("body", body) ] -> let* arg_count = int_of_json arg_count in let* locals = list_of_json var_of_json locals in - let* body = statement_of_json body in + let* body = statement_of_json body fun_count in Ok { A.arg_count; locals; body } | _ -> Error "") -let fun_decl_of_json (js : json) : (A.fun_decl, string) result = +let fun_decl_of_json (js : json) (fun_count : int) : (A.fun_decl, string) result = combine_error_msgs js "fun_decl_of_json" (match js with | `Assoc @@ -636,11 +650,42 @@ let fun_decl_of_json (js : json) : (A.fun_decl, string) result = ("signature", signature); ("body", body); ] -> - let* def_id = A.FunDeclId.id_of_json def_id in + let* def_id = FunDeclId.id_of_json def_id in let* name = fun_name_of_json name in let* signature = fun_sig_of_json signature in - let* body = option_of_json fun_body_of_json body in - Ok { A.def_id; name; signature; body } + let* body = option_of_json (fun js -> fun_body_of_json js fun_count) body in + Ok { A.def_id; name; signature; body; is_global = false; } + | _ -> Error "") + + +(* Converts a global declaration to a function declaration. + +A.fun_sig +ety_no_regions_to_rty +*) +let global_decl_of_json (js : json) (fun_count: int) : (A.fun_decl, string) result = + combine_error_msgs js "global_decl_of_json" + (match js with + | `Assoc + [ + ("def_id", def_id); + ("name", name); + ("type_", type_); + ("body", body); + ] -> + let* def_id = global_id_of_json def_id fun_count in + let* name = fun_name_of_json name in + let* type_ = ety_of_json type_ in + let* body = option_of_json (fun js -> fun_body_of_json js fun_count) body in + let signature : A.fun_sig = { + region_params = []; + num_early_bound_regions = 0; + regions_hierarchy = []; + type_params = []; + inputs = []; + output = TU.ety_no_regions_to_sty type_; + } in + Ok { A.def_id; name; signature; body; is_global = true; } | _ -> Error "") let g_declaration_group_of_json (id_of_json : json -> ('id, string) result) @@ -663,9 +708,14 @@ let type_declaration_group_of_json (js : json) : let fun_declaration_group_of_json (js : json) : (M.fun_declaration_group, string) result = combine_error_msgs js "fun_declaration_group_of_json" - (g_declaration_group_of_json A.FunDeclId.id_of_json js) + (g_declaration_group_of_json FunDeclId.id_of_json js) + +let global_declaration_group_of_json (js : json) (fun_count: int) : + (M.fun_declaration_group, string) result = + combine_error_msgs js "global_declaration_group_of_json" + (g_declaration_group_of_json (fun js -> global_id_of_json js fun_count) js) -let declaration_group_of_json (js : json) : (M.declaration_group, string) result +let declaration_group_of_json (js : json) (fun_count: int) : (M.declaration_group, string) result = combine_error_msgs js "declaration_of_json" (match js with @@ -675,8 +725,17 @@ let declaration_group_of_json (js : json) : (M.declaration_group, string) result | `Assoc [ ("Fun", `List [ decl ]) ] -> let* decl = fun_declaration_group_of_json decl in Ok (M.Fun decl) + | `Assoc [ ("Global", `List [ decl ]) ] -> + let* decl = global_declaration_group_of_json decl fun_count in + Ok (M.Fun decl) | _ -> Error "") +let length_of_json_list (js: json) : (int, string) result = + combine_error_msgs js "get_json_list_len" + (match js with + | `List jsl -> Ok (List.length jsl) + | _ -> Error ("not a list: " ^ show js)) + let llbc_module_of_json (js : json) : (M.llbc_module, string) result = combine_error_msgs js "llbc_module_of_json" (match js with @@ -686,12 +745,15 @@ let llbc_module_of_json (js : json) : (M.llbc_module, string) result = ("declarations", declarations); ("types", types); ("functions", functions); + ("globals", globals); ] -> + let* fun_count = length_of_json_list functions in let* name = string_of_json name in let* declarations = - list_of_json declaration_group_of_json declarations + list_of_json (fun js -> declaration_group_of_json js fun_count) declarations in let* types = list_of_json type_decl_of_json types in - let* functions = list_of_json fun_decl_of_json functions in - Ok { M.name; declarations; types; functions } + let* functions = list_of_json (fun js -> fun_decl_of_json js fun_count) functions in + let* globals = list_of_json (fun js -> global_decl_of_json js fun_count) globals in + Ok { M.name; declarations; types; functions = functions @ globals } | _ -> Error "") diff --git a/src/Modules.ml b/src/Modules.ml index f52983c6..6d0cf70c 100644 --- a/src/Modules.ml +++ b/src/Modules.ml @@ -1,5 +1,6 @@ open Types open LlbcAst +open FunIdentifier type 'id g_declaration_group = NonRec of 'id | Rec of 'id list [@@deriving show] diff --git a/src/Print.ml b/src/Print.ml index 8e29bc67..28040181 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -1,4 +1,5 @@ open Names +open FunIdentifier module T = Types module TU = TypesUtils module V = Values @@ -685,7 +686,7 @@ module LlbcAst = struct var_id_to_string : V.VarId.id -> string; adt_field_names : T.TypeDeclId.id -> T.VariantId.id option -> string list option; - fun_decl_id_to_string : A.FunDeclId.id -> string; + fun_decl_id_to_string : FunDeclId.id -> string; } let ast_to_ctx_formatter (fmt : ast_formatter) : PC.ctx_formatter = @@ -755,7 +756,7 @@ module LlbcAst = struct } let fun_decl_to_ast_formatter (type_decls : T.type_decl T.TypeDeclId.Map.t) - (fun_decls : A.fun_decl A.FunDeclId.Map.t) (fdef : A.fun_decl) : + (fun_decls : A.fun_decl FunDeclId.Map.t) (fdef : A.fun_decl) : ast_formatter = let rvar_to_string r = let rvar = T.RegionVarId.nth fdef.signature.region_params r in @@ -781,7 +782,7 @@ module LlbcAst = struct let adt_field_names = PC.type_ctx_to_adt_field_names_fun type_decls in let adt_field_to_string = type_ctx_to_adt_field_to_string_fun type_decls in let fun_decl_id_to_string def_id = - let def = A.FunDeclId.Map.find def_id fun_decls in + let def = FunDeclId.Map.find def_id fun_decls in fun_name_to_string def.name in { @@ -1138,7 +1139,7 @@ module Module = struct (** Generate an [ast_formatter] by using a definition context in combination with the variables local to a function's definition *) let def_ctx_to_ast_formatter (type_context : T.type_decl T.TypeDeclId.Map.t) - (fun_context : A.fun_decl A.FunDeclId.Map.t) (def : A.fun_decl) : + (fun_context : A.fun_decl FunDeclId.Map.t) (def : A.fun_decl) : PA.ast_formatter = let rvar_to_string vid = let var = T.RegionVarId.nth def.signature.region_params vid in @@ -1157,7 +1158,7 @@ module Module = struct name_to_string def.name in let fun_decl_id_to_string def_id = - let def = A.FunDeclId.Map.find def_id fun_context in + let def = FunDeclId.Map.find def_id fun_context in fun_name_to_string def.name in let var_id_to_string vid = @@ -1186,7 +1187,7 @@ module Module = struct (** This function pretty-prints a function definition by using a definition context *) let fun_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) - (fun_context : A.fun_decl A.FunDeclId.Map.t) (def : A.fun_decl) : string = + (fun_context : A.fun_decl FunDeclId.Map.t) (def : A.fun_decl) : string = let fmt = def_ctx_to_ast_formatter type_context fun_context def in PA.fun_decl_to_string fmt "" " " def diff --git a/src/PrintPure.ml b/src/PrintPure.ml index 5e817dde..8864dafe 100644 --- a/src/PrintPure.ml +++ b/src/PrintPure.ml @@ -2,6 +2,7 @@ open Pure open PureUtils +open FunIdentifier module T = Types module V = Values module E = Expressions @@ -12,7 +13,6 @@ module RegionId = T.RegionId module VariantId = T.VariantId module FieldId = T.FieldId module SymbolicValueId = V.SymbolicValueId -module FunDeclId = A.FunDeclId type type_formatter = { type_var_id_to_string : TypeVarId.id -> string; @@ -44,7 +44,7 @@ type ast_formatter = { adt_field_to_string : TypeDeclId.id -> VariantId.id option -> FieldId.id -> string option; adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; - fun_decl_id_to_string : A.FunDeclId.id -> string; + fun_decl_id_to_string : FunDeclId.id -> string; } let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = @@ -110,7 +110,7 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) Print.LlbcAst.type_ctx_to_adt_field_to_string_fun type_decls in let fun_decl_id_to_string def_id = - let def = A.FunDeclId.Map.find def_id fun_decls in + let def = FunDeclId.Map.find def_id fun_decls in fun_name_to_string def.name in { diff --git a/src/PrintSymbolicAst.ml b/src/PrintSymbolicAst.ml index 0ab68efc..e44b422a 100644 --- a/src/PrintSymbolicAst.ml +++ b/src/PrintSymbolicAst.ml @@ -7,6 +7,7 @@ open Errors open Identifiers +open FunIdentifier module T = Types module TU = TypesUtils module V = Values @@ -20,7 +21,7 @@ module PT = Print.Types type formatting_ctx = { type_context : C.type_context; - fun_context : A.fun_decl A.FunDeclId.Map.t; + fun_context : A.fun_decl FunDeclId.Map.t; type_vars : T.type_var list; } diff --git a/src/Pure.ml b/src/Pure.ml index 5834b87f..05f78e35 100644 --- a/src/Pure.ml +++ b/src/Pure.ml @@ -1,5 +1,6 @@ open Identifiers open Names +open FunIdentifier module T = Types module V = Values module E = Expressions @@ -10,7 +11,6 @@ module RegionGroupId = T.RegionGroupId module VariantId = T.VariantId module FieldId = T.FieldId module SymbolicValueId = V.SymbolicValueId -module FunDeclId = A.FunDeclId module SynthPhaseId = IdGen () (** We give an identifier to every phase of the synthesis (forward, backward diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml index 1c530011..55a8853a 100644 --- a/src/PureToExtract.ml +++ b/src/PureToExtract.ml @@ -6,6 +6,7 @@ open Pure open TranslateCore +open FunIdentifier module C = Contexts module RegionVarId = T.RegionVarId module F = Format diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml index 42479a6e..2b416cc1 100644 --- a/src/SymbolicToPure.ml +++ b/src/SymbolicToPure.ml @@ -2,6 +2,7 @@ open Errors open LlbcAstUtils open Pure open PureUtils +open FunIdentifier module Id = Identifiers module M = Modules module S = SymbolicAst diff --git a/src/Translate.ml b/src/Translate.ml index 57b92e44..1577753c 100644 --- a/src/Translate.ml +++ b/src/Translate.ml @@ -1,5 +1,6 @@ open InterpreterStatements open Interpreter +open FunIdentifier module L = Logging module T = Types module A = LlbcAst @@ -351,8 +352,8 @@ type gen_ctx = { m : M.llbc_module; extract_ctx : PureToExtract.extraction_ctx; trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; - trans_funs : (bool * pure_fun_translation) Pure.FunDeclId.Map.t; - functions_with_decreases_clause : Pure.FunDeclId.Set.t; + trans_funs : (bool * pure_fun_translation) FunDeclId.Map.t; + functions_with_decreases_clause : FunDeclId.Set.t; } (** Extraction context *) @@ -388,7 +389,7 @@ let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = ctx.trans_types in let has_opaque_funs = - Pure.FunDeclId.Map.exists + FunDeclId.Map.exists (fun _ ((_, (t_fwd, _)) : bool * pure_fun_translation) -> Option.is_none t_fwd.body) ctx.trans_funs @@ -427,7 +428,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) (* Utility to check a function has a decrease clause *) let has_decreases_clause (def : Pure.fun_decl) : bool = - Pure.FunDeclId.Set.mem def.def_id ctx.functions_with_decreases_clause + FunDeclId.Set.mem def.def_id ctx.functions_with_decreases_clause in (* In case of (non-mutually) recursive functions, we use a simple procedure to @@ -523,14 +524,14 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) ids | Fun (NonRec id) -> (* Lookup *) - let pure_fun = Pure.FunDeclId.Map.find id ctx.trans_funs in + let pure_fun = FunDeclId.Map.find id ctx.trans_funs in (* Translate *) export_functions false [ pure_fun ] | Fun (Rec ids) -> (* General case of mutually recursive functions *) (* Lookup *) let pure_funs = - List.map (fun id -> Pure.FunDeclId.Map.find id ctx.trans_funs) ids + List.map (fun id -> FunDeclId.Map.find id ctx.trans_funs) ids in (* Translate *) export_functions true pure_funs @@ -622,7 +623,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) (* We need to compute which functions are recursive, in order to know * whether we should generate a decrease clause or not. *) let rec_functions = - Pure.FunDeclId.Set.of_list + FunDeclId.Set.of_list (List.concat (List.map (fun decl -> match decl with M.Fun (Rec ids) -> ids | _ -> []) @@ -644,7 +645,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) (fun ctx (keep_fwd, def) -> (* Note that we generate a decrease clause for all the recursive functions *) let gen_decr_clause = - Pure.FunDeclId.Set.mem (fst def).Pure.def_id rec_functions + FunDeclId.Set.mem (fst def).Pure.def_id rec_functions in ExtractToFStar.extract_fun_decl_register_names ctx keep_fwd gen_decr_clause def) @@ -674,7 +675,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) in let trans_funs = - Pure.FunDeclId.Map.of_list + FunDeclId.Map.of_list (List.map (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> (fd.def_id, (keep_fwd, (fd, bdl)))) @@ -761,7 +762,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) (* Extract the template clauses *) let needs_clauses_module = config.extract_decreases_clauses - && not (Pure.FunDeclId.Set.is_empty rec_functions) + && not (FunDeclId.Set.is_empty rec_functions) in (if needs_clauses_module && config.extract_template_decreases_clauses then let clauses_filename = extract_filebasename ^ ".Clauses.Template.fst" in diff --git a/src/TranslateCore.ml b/src/TranslateCore.ml index 17c35cbf..3d3887ce 100644 --- a/src/TranslateCore.ml +++ b/src/TranslateCore.ml @@ -1,6 +1,7 @@ (** Some utilities for the translation *) open InterpreterStatements +open FunIdentifier module L = Logging module T = Types module A = LlbcAst @@ -14,8 +15,8 @@ let log = L.translate_log type type_context = C.type_context [@@deriving show] type fun_context = { - fun_decls : A.fun_decl A.FunDeclId.Map.t; - fun_infos : FA.fun_info A.FunDeclId.Map.t; + fun_decls : A.fun_decl FunDeclId.Map.t; + fun_infos : FA.fun_info FunDeclId.Map.t; } [@@deriving show] @@ -49,6 +50,6 @@ let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = let fmt = PrintPure.mk_ast_formatter type_decls fun_decls type_params in PrintPure.fun_decl_to_string fmt def -let fun_decl_id_to_string (ctx : trans_ctx) (id : Pure.FunDeclId.id) : string = +let fun_decl_id_to_string (ctx : trans_ctx) (id : FunDeclId.id) : string = Print.fun_name_to_string - (Pure.FunDeclId.Map.find id ctx.fun_context.fun_decls).name + (FunDeclId.Map.find id ctx.fun_context.fun_decls).name diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml index bee7956e..8d0624ee 100644 --- a/src/TypesUtils.ml +++ b/src/TypesUtils.ml @@ -100,28 +100,31 @@ let rty_regions_intersect (ty : rty) (regions : RegionId.Set.t) : bool = let ty_regions = rty_regions ty in not (RegionId.Set.disjoint ty_regions regions) -(** Convert an [ety], containing no region variables, to an [rty]. +(** Convert an [ety], containing no region variables, to an [rty] or [sty]. In practice, it is the identity. *) -let rec ety_no_regions_to_rty (ty : ety) : rty = +let rec ety_no_regions_to_gr_ty (ty : ety) : 'a gr_ty = match ty with | Adt (type_id, regions, tys) -> assert (regions = []); - Adt (type_id, [], List.map ety_no_regions_to_rty tys) + Adt (type_id, [], List.map ety_no_regions_to_gr_ty tys) | TypeVar v -> TypeVar v | Bool -> Bool | Char -> Char | Never -> Never | Integer int_ty -> Integer int_ty | Str -> Str - | Array ty -> Array (ety_no_regions_to_rty ty) - | Slice ty -> Slice (ety_no_regions_to_rty ty) + | Array ty -> Array (ety_no_regions_to_gr_ty ty) + | Slice ty -> Slice (ety_no_regions_to_gr_ty ty) | Ref (_, _, _) -> failwith "Can't convert a ref with erased regions to a ref with non-erased \ regions" +let ety_no_regions_to_rty (ty : ety) : rty = ety_no_regions_to_gr_ty ty +let ety_no_regions_to_sty (ty : ety) : sty = ety_no_regions_to_gr_ty ty + (** Retuns true if the type contains borrows. Note that we can't simply explore the type and look for regions: sometimes -- cgit v1.2.3 From 414769e0c9a1d370d3ab906b710e2e8adfe25e5e Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Mon, 13 Jun 2022 17:10:43 +0200 Subject: crude generation working - missing unit tests & special constants handling --- src/ExtractToFStar.ml | 5 +- src/FunIdentifier.ml | 1 + src/InterpreterExpressions.ml | 114 +++++++++++++++++++++++------------------- src/Print.ml | 1 + src/Pure.ml | 1 + 5 files changed, 70 insertions(+), 52 deletions(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 9766ddaf..b85c146b 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -902,7 +902,10 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) | AdtCons adt_cons_id -> extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args args | Proj proj -> - extract_field_projector ctx fmt inside app proj qualif.type_args args) + extract_field_projector ctx fmt inside app proj qualif.type_args args + (* TODO | Global global_id -> + extract_global_ref ctx fmt inside global_id*) + ) | _ -> (* "Regular" expression *) (* Open parentheses *) diff --git a/src/FunIdentifier.ml b/src/FunIdentifier.ml index dd7e9318..956fce3f 100644 --- a/src/FunIdentifier.ml +++ b/src/FunIdentifier.ml @@ -1,2 +1,3 @@ open Identifiers module FunDeclId = IdGen () +module GlobalDeclId = IdGen () diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index 4549365d..ee26d00d 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -1,5 +1,6 @@ module T = Types module V = Values +module LA = LlbcAst open Scalars module E = Expressions open Errors @@ -71,53 +72,67 @@ let prepare_rplace (config : C.config) (expand_prim_copy : bool) comp cc read_place cf ctx (** Convert an operand constant operand value to a typed value *) -let rec operand_constant_value_to_typed_value (ctx : C.eval_ctx) (ty : T.ety) - (cv : E.operand_constant_value) : V.typed_value = - (* Check the type while converting - we actually need some information - * contained in the type *) - log#ldebug - (lazy - ("operand_constant_value_to_typed_value:" ^ "\n- ty: " - ^ ety_to_string ctx ty ^ "\n- cv: " - ^ operand_constant_value_to_string ctx cv)); - match (ty, cv) with - (* Adt *) - | ( T.Adt (adt_id, region_params, type_params), - ConstantAdt (variant_id, field_values) ) -> - assert (region_params = []); - (* Compute the types of the fields *) - let field_tys = - match adt_id with - | T.AdtId def_id -> - let def = C.ctx_lookup_type_decl ctx def_id in - assert (def.region_params = []); - Subst.type_decl_get_instantiated_field_etypes def variant_id - type_params - | T.Tuple -> type_params - | T.Assumed _ -> failwith "Unreachable" - in - (* Compute the field values *) - let field_values = - List.map - (fun (ty, v) -> operand_constant_value_to_typed_value ctx ty v) +let rec eval_operand_constant_value (ty : T.ety) + (cv : E.operand_constant_value) (cf : V.typed_value -> m_fun) : m_fun = + fun ctx -> + (* Check the type while converting - we actually need some information + * contained in the type *) + log#ldebug + (lazy + ("eval_operand_constant_value:" ^ "\n- ty: " + ^ ety_to_string ctx ty ^ "\n- cv: " + ^ operand_constant_value_to_string ctx cv)); + match (ty, cv) with + (* Adt *) + | ( T.Adt (adt_id, region_params, type_params), + ConstantAdt (variant_id, field_values) ) -> + assert (region_params = []); + (* Compute the types of the fields *) + let field_tys = + match adt_id with + | T.AdtId def_id -> + let def = C.ctx_lookup_type_decl ctx def_id in + assert (def.region_params = []); + Subst.type_decl_get_instantiated_field_etypes def variant_id + type_params + | T.Tuple -> type_params + | T.Assumed _ -> failwith "Unreachable" + in + let adt_cf = fun fields ctx -> + let value = V.Adt { variant_id; field_values = fields } in + cf { value; ty } ctx + in + (* Map the field values & types to the continuation above *) + fold_left_apply_continuation + (fun (ty, v) cf ctx -> eval_operand_constant_value ty v cf ctx) (List.combine field_tys field_values) - in - (* Put together *) - let value = V.Adt { variant_id; field_values } in - { value; ty } - (* Scalar, boolean... *) - | T.Bool, ConstantValue (Bool v) -> { V.value = V.Concrete (Bool v); ty } - | T.Char, ConstantValue (Char v) -> { V.value = V.Concrete (Char v); ty } - | T.Str, ConstantValue (String v) -> { V.value = V.Concrete (String v); ty } - | T.Integer int_ty, ConstantValue (V.Scalar v) -> - (* Check the type and the ranges *) - assert (int_ty = v.int_ty); - assert (check_scalar_value_in_range v); - { V.value = V.Concrete (V.Scalar v); ty } - (* Remaining cases (invalid) - listing as much as we can on purpose - (allows to catch errors at compilation if the definitions change) *) - | _, ConstantAdt _ | _, ConstantValue _ -> - failwith "Improperly typed constant value" + adt_cf ctx + (* Scalar, boolean... *) + | T.Bool, ConstantValue (Bool v) -> cf { V.value = V.Concrete (Bool v); ty } ctx + | T.Char, ConstantValue (Char v) -> cf { V.value = V.Concrete (Char v); ty } ctx + | T.Str, ConstantValue (String v) -> cf { V.value = V.Concrete (String v); ty } ctx + | T.Integer int_ty, ConstantValue (V.Scalar v) -> + (* Check the type and the ranges *) + assert (int_ty = v.int_ty); + assert (check_scalar_value_in_range v); + cf { V.value = V.Concrete (V.Scalar v); ty } ctx + (* Constant expression identifier *) + | ty, ConstantId id -> + let dest = mk_fresh_symbolic_value V.FunCallRet (ety_no_regions_to_rty ty) in + + (* Call the continuation *) + let expr = cf (mk_typed_value_from_symbolic_value dest) ctx in + + (* TODO Should it really be a new call ID ? *) + let call = SA.Fun (LA.Regular id, C.fresh_fun_call_id ()) in + + S.synthesize_function_call call [] [] [] [] + dest None(*TODO meta-info*) expr + + (* Remaining cases (invalid) - listing as much as we can on purpose + (allows to catch errors at compilation if the definitions change) *) + | _, ConstantAdt _ | _, ConstantValue _ -> + failwith "Improperly typed constant value" (** Prepare the evaluation of an operand. @@ -157,8 +172,7 @@ let eval_operand_prepare (config : C.config) (op : E.operand) fun ctx -> match op with | Expressions.Constant (ty, cv) -> - let v = operand_constant_value_to_typed_value ctx ty cv in - cf v ctx + eval_operand_constant_value ty cv cf ctx | Expressions.Copy p -> (* Access the value *) let access = Read in @@ -191,9 +205,7 @@ let eval_operand (config : C.config) (op : E.operand) ^ eval_ctx_to_string ctx ^ "\n")); (* Evaluate *) match op with - | Expressions.Constant (ty, cv) -> - let v = operand_constant_value_to_typed_value ctx ty cv in - cf v ctx + | Expressions.Constant (ty, cv) -> eval_operand_constant_value ty cv cf ctx | Expressions.Copy p -> (* Access the value *) let access = Read in diff --git a/src/Print.ml b/src/Print.ml index 28040181..9e2ff3cd 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -863,6 +863,7 @@ module LlbcAst = struct let rec operand_constant_value_to_string (fmt : ast_formatter) (cv : E.operand_constant_value) : string = match cv with + | E.ConstantId id -> fmt.fun_decl_id_to_string id | E.ConstantValue cv -> PV.constant_value_to_string cv | E.ConstantAdt (variant_id, field_values) -> (* This is a bit annoying, because we don't have context information diff --git a/src/Pure.ml b/src/Pure.ml index 05f78e35..256a872a 100644 --- a/src/Pure.ml +++ b/src/Pure.ml @@ -305,6 +305,7 @@ type qualif_id = | Func of fun_id | AdtCons of adt_cons_id (** A function or ADT constructor identifier *) | Proj of projection (** Field projector *) + (* TODO | Global of GlobalDeclId.id*) [@@deriving show] type qualif = { id : qualif_id; type_args : ty list } [@@deriving show] -- cgit v1.2.3 From 7703c4ca86a390303d0a120f8811c8fd704c5168 Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Tue, 21 Jun 2022 11:41:09 +0200 Subject: concrete & symbolic evaluation work with new LLBC format --- src/Contexts.ml | 11 ++- src/Expressions.ml | 23 +----- src/ExtractToFStar.ml | 3 +- src/FunIdentifier.ml | 3 - src/FunsAnalysis.ml | 1 - src/Interpreter.ml | 7 +- src/InterpreterExpressions.ml | 83 +++++--------------- src/InterpreterStatements.ml | 16 +++- src/InterpreterUtils.ml | 2 - src/LlbcAst.ml | 27 ++++++- src/LlbcAstUtils.ml | 1 - src/LlbcOfJson.ml | 173 ++++++++++++++++++++---------------------- src/Modules.ml | 2 +- src/Print.ml | 78 +++++++++---------- src/PrintPure.ml | 7 +- src/Pure.ml | 3 +- src/PureToExtract.ml | 13 ++-- src/Substitute.ml | 11 +-- src/SymbolicToPure.ml | 27 ++++--- src/Translate.ml | 36 +++++---- src/TranslateCore.ml | 10 +-- src/main.ml | 30 ++++---- 22 files changed, 260 insertions(+), 307 deletions(-) delete mode 100644 src/FunIdentifier.ml (limited to 'src') diff --git a/src/Contexts.ml b/src/Contexts.ml index bbf5b8f3..1fbc916b 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -1,7 +1,6 @@ open Types open Values open LlbcAst -open FunIdentifier module V = Values open ValuesUtils module M = Modules @@ -218,7 +217,11 @@ type type_context = { } [@@deriving show] -type fun_context = { fun_decls : fun_decl FunDeclId.Map.t } [@@deriving show] +type fun_context = { + fun_decls : fun_decl FunDeclId.Map.t; + gid_conv : global_id_converter; +} +[@@deriving show] type eval_ctx = { type_context : type_context; @@ -256,6 +259,10 @@ let ctx_lookup_type_decl (ctx : eval_ctx) (tid : TypeDeclId.id) : type_decl = let ctx_lookup_fun_decl (ctx : eval_ctx) (fid : FunDeclId.id) : fun_decl = FunDeclId.Map.find fid ctx.fun_context.fun_decls +(** TODO: make this more efficient with maps *) +let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : fun_decl = + ctx_lookup_fun_decl ctx (global_to_fun_id ctx.fun_context.gid_conv gid) + (** Retrieve a variable's value in an environment *) let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = (* We take care to stop at the end of current frame: different variables diff --git a/src/Expressions.ml b/src/Expressions.ml index f1a4a8c3..6645a77f 100644 --- a/src/Expressions.ml +++ b/src/Expressions.ml @@ -1,6 +1,5 @@ open Types open Values -open FunIdentifier type field_proj_kind = | ProjAdt of TypeDeclId.id * VariantId.id option @@ -73,31 +72,11 @@ let all_binops = Shr; ] -(** Constant value for an operand - - It is a bit annoying, but rustc treats some ADT and tuple instances as - constants when generating MIR: - - an enumeration with one variant and no fields is a constant. - - a structure with no field is a constant. - - sometimes, Rust stores the initialization of an ADT as a constant - (if all the fields are constant) rather than as an aggregated value - - For our translation, we use the following enumeration to encode those - special cases in assignments. They are converted to "normal" values - when evaluating the assignment (which is why we don't put them in the - [ConstantValue] enumeration). - *) -type operand_constant_value = - | ConstantValue of constant_value - | ConstantId of FunDeclId.id - | ConstantAdt of VariantId.id option * operand_constant_value list -[@@deriving show] - (* TODO: symplify the operand constant values *) type operand = | Copy of place | Move of place - | Constant of ety * operand_constant_value + | Constant of ety * constant_value [@@deriving show] (** An aggregated ADT. diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index b85c146b..b89579b5 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -6,7 +6,6 @@ open PureUtils open TranslateCore open PureToExtract open StringUtils -open FunIdentifier module F = Format (** A qualifier for a type definition. @@ -315,7 +314,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) fname ^ suffix in - let decreases_clause_name (_fid : FunDeclId.id) (fname : fun_name) : string = + let decreases_clause_name (_fid : A.FunDeclId.id) (fname : fun_name) : string = let fname = fun_name_to_snake_case fname in (* Compute the suffix *) let suffix = "_decreases" in diff --git a/src/FunIdentifier.ml b/src/FunIdentifier.ml deleted file mode 100644 index 956fce3f..00000000 --- a/src/FunIdentifier.ml +++ /dev/null @@ -1,3 +0,0 @@ -open Identifiers -module FunDeclId = IdGen () -module GlobalDeclId = IdGen () diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index cf2e0bd6..dc205eb9 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -9,7 +9,6 @@ open LlbcAst open Modules -open FunIdentifier type fun_info = { can_fail : bool; diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 702aeea6..5affea4c 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -1,5 +1,4 @@ open Cps -open FunIdentifier open InterpreterUtils open InterpreterProjectors open InterpreterBorrows @@ -25,7 +24,7 @@ let compute_type_fun_contexts (m : M.llbc_module) : TypesAnalysis.analyze_type_declarations type_decls type_decls_list in let type_context = { C.type_decls_groups; type_decls; type_infos } in - let fun_context = { C.fun_decls } in + let fun_context = { C.fun_decls; gid_conv = m.gid_conv } in (type_context, fun_context) let initialize_eval_context (type_context : C.type_context) @@ -256,9 +255,9 @@ module Test = struct environment. *) let test_unit_function (config : C.partial_config) (m : M.llbc_module) - (fid : FunDeclId.id) : unit = + (fid : A.FunDeclId.id) : unit = (* Retrieve the function declaration *) - let fdef = FunDeclId.nth m.functions fid in + let fdef = A.FunDeclId.nth m.functions fid in let body = Option.get fdef.body in (* Debug *) diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index ee26d00d..57ee0526 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -71,68 +71,23 @@ let prepare_rplace (config : C.config) (expand_prim_copy : bool) in comp cc read_place cf ctx -(** Convert an operand constant operand value to a typed value *) -let rec eval_operand_constant_value (ty : T.ety) - (cv : E.operand_constant_value) (cf : V.typed_value -> m_fun) : m_fun = - fun ctx -> - (* Check the type while converting - we actually need some information - * contained in the type *) - log#ldebug - (lazy - ("eval_operand_constant_value:" ^ "\n- ty: " - ^ ety_to_string ctx ty ^ "\n- cv: " - ^ operand_constant_value_to_string ctx cv)); - match (ty, cv) with - (* Adt *) - | ( T.Adt (adt_id, region_params, type_params), - ConstantAdt (variant_id, field_values) ) -> - assert (region_params = []); - (* Compute the types of the fields *) - let field_tys = - match adt_id with - | T.AdtId def_id -> - let def = C.ctx_lookup_type_decl ctx def_id in - assert (def.region_params = []); - Subst.type_decl_get_instantiated_field_etypes def variant_id - type_params - | T.Tuple -> type_params - | T.Assumed _ -> failwith "Unreachable" - in - let adt_cf = fun fields ctx -> - let value = V.Adt { variant_id; field_values = fields } in - cf { value; ty } ctx - in - (* Map the field values & types to the continuation above *) - fold_left_apply_continuation - (fun (ty, v) cf ctx -> eval_operand_constant_value ty v cf ctx) - (List.combine field_tys field_values) - adt_cf ctx - (* Scalar, boolean... *) - | T.Bool, ConstantValue (Bool v) -> cf { V.value = V.Concrete (Bool v); ty } ctx - | T.Char, ConstantValue (Char v) -> cf { V.value = V.Concrete (Char v); ty } ctx - | T.Str, ConstantValue (String v) -> cf { V.value = V.Concrete (String v); ty } ctx - | T.Integer int_ty, ConstantValue (V.Scalar v) -> - (* Check the type and the ranges *) - assert (int_ty = v.int_ty); - assert (check_scalar_value_in_range v); - cf { V.value = V.Concrete (V.Scalar v); ty } ctx - (* Constant expression identifier *) - | ty, ConstantId id -> - let dest = mk_fresh_symbolic_value V.FunCallRet (ety_no_regions_to_rty ty) in - - (* Call the continuation *) - let expr = cf (mk_typed_value_from_symbolic_value dest) ctx in - - (* TODO Should it really be a new call ID ? *) - let call = SA.Fun (LA.Regular id, C.fresh_fun_call_id ()) in - - S.synthesize_function_call call [] [] [] [] - dest None(*TODO meta-info*) expr - - (* Remaining cases (invalid) - listing as much as we can on purpose - (allows to catch errors at compilation if the definitions change) *) - | _, ConstantAdt _ | _, ConstantValue _ -> - failwith "Improperly typed constant value" +(** Convert a constant operand value to a typed value *) +let typecheck_constant_value (ty : T.ety) (cv : V.constant_value) : V.typed_value = + (* Check the type while converting - + * we actually need some information contained in the type *) + match (ty, cv) with + (* Scalar, boolean... *) + | T.Bool, (Bool v) -> { V.value = V.Concrete (Bool v); ty } + | T.Char, (Char v) -> { V.value = V.Concrete (Char v); ty } + | T.Str, (String v) -> { V.value = V.Concrete (String v); ty } + | T.Integer int_ty, (V.Scalar v) -> + (* Check the type and the ranges *) + assert (int_ty = v.int_ty); + assert (check_scalar_value_in_range v); + { V.value = V.Concrete (V.Scalar v); ty } + (* Remaining cases (invalid) - listing as much as we can on purpose + (allows to catch errors at compilation if the definitions change) *) + | _, _ -> failwith "Improperly typed constant value" (** Prepare the evaluation of an operand. @@ -172,7 +127,7 @@ let eval_operand_prepare (config : C.config) (op : E.operand) fun ctx -> match op with | Expressions.Constant (ty, cv) -> - eval_operand_constant_value ty cv cf ctx + cf (typecheck_constant_value ty cv) ctx | Expressions.Copy p -> (* Access the value *) let access = Read in @@ -205,7 +160,7 @@ let eval_operand (config : C.config) (op : E.operand) ^ eval_ctx_to_string ctx ^ "\n")); (* Evaluate *) match op with - | Expressions.Constant (ty, cv) -> eval_operand_constant_value ty cv cf ctx + | Expressions.Constant (ty, cv) -> cf (typecheck_constant_value ty cv) ctx | Expressions.Copy p -> (* Access the value *) let access = Read in diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index c7308720..e5564d59 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -7,7 +7,6 @@ module A = LlbcAst module L = Logging open TypesUtils open ValuesUtils -open FunIdentifier module Inv = Invariants module S = SynthesizeSymbolic open Errors @@ -822,6 +821,15 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = (* Compose and apply *) comp cf_eval_rvalue cf_assign cf ctx + | A.AssignGlobal { dst; global } -> + let call : A.call = { + func = A.Regular (A.global_to_fun_id ctx.fun_context.gid_conv global); + region_args = []; + type_args = []; + args = []; + dest = { var_id = dst; projection = [] }; + } in + eval_function_call config call cf ctx | A.FakeRead p -> let expand_prim_copy = false in let cf_prepare = prepare_rplace config expand_prim_copy Read p in @@ -1002,7 +1010,7 @@ and eval_function_call (config : C.config) (call : A.call) : st_cm_fun = call.args call.dest (** Evaluate a local (i.e., non-assumed) function call in concrete mode *) -and eval_local_function_call_concrete (config : C.config) (fid : FunDeclId.id) +and eval_local_function_call_concrete (config : C.config) (fid : A.FunDeclId.id) (region_args : T.erased_region list) (type_args : T.ety list) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> @@ -1080,7 +1088,7 @@ and eval_local_function_call_concrete (config : C.config) (fid : FunDeclId.id) cc cf ctx (** Evaluate a local (i.e., non-assumed) function call in symbolic mode *) -and eval_local_function_call_symbolic (config : C.config) (fid : FunDeclId.id) +and eval_local_function_call_symbolic (config : C.config) (fid : A.FunDeclId.id) (region_args : T.erased_region list) (type_args : T.ety list) (args : E.operand list) (dest : E.place) : st_cm_fun = fun cf ctx -> @@ -1301,7 +1309,7 @@ and eval_non_local_function_call (config : C.config) (fid : A.assumed_fun_id) (** Evaluate a local (i.e, not assumed) function call (auxiliary helper for [eval_statement]) *) -and eval_local_function_call (config : C.config) (fid : FunDeclId.id) +and eval_local_function_call (config : C.config) (fid : A.FunDeclId.id) (region_args : T.erased_region list) (type_args : T.ety list) (args : E.operand list) (dest : E.place) : st_cm_fun = match config.mode with diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 7a2e22f7..47323cc2 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -33,8 +33,6 @@ let typed_value_to_string = PA.typed_value_to_string let typed_avalue_to_string = PA.typed_avalue_to_string -let operand_constant_value_to_string = PA.operand_constant_value_to_string - let place_to_string = PA.place_to_string let operand_to_string = PA.operand_to_string diff --git a/src/LlbcAst.ml b/src/LlbcAst.ml index 4324586d..16733e20 100644 --- a/src/LlbcAst.ml +++ b/src/LlbcAst.ml @@ -2,7 +2,21 @@ open Names open Types open Values open Expressions -open FunIdentifier +open Identifiers + +module FunDeclId = IdGen () +module GlobalDeclId = IdGen () + +(* Strict type for the number of function declarations (see [global_to_fun_id] below) *) +type global_id_converter = { fun_count : int } +[@@deriving show] + +(** Converts a global id to its corresponding function id. + To do so, it adds the global id to the number of function declarations : + We have the bijection `global_id <=> fun_id + fun_id_count`. +*) +let global_to_fun_id (conv : global_id_converter) (gid : GlobalDeclId.id) : FunDeclId.id = + FunDeclId.of_int ((GlobalDeclId.to_int gid) + conv.fun_count) type var = { index : VarId.id; (** Unique variable identifier *) @@ -34,6 +48,12 @@ type assumed_fun_id = type fun_id = Regular of FunDeclId.id | Assumed of assumed_fun_id [@@deriving show, ord] +type assign_global = { + dst : VarId.id; + global : GlobalDeclId.id; +} +[@@deriving show] + type assertion = { cond : operand; expected : bool } [@@deriving show] type abs_region_group = (AbstractionId.id, RegionId.id) g_region_group @@ -75,6 +95,8 @@ class ['self] iter_statement_base = object (_self : 'self) inherit [_] VisitorsRuntime.iter + method visit_assign_global : 'env -> assign_global -> unit = fun _ _ -> () + method visit_place : 'env -> place -> unit = fun _ _ -> () method visit_rvalue : 'env -> rvalue -> unit = fun _ _ -> () @@ -97,6 +119,8 @@ class ['self] map_statement_base = object (_self : 'self) inherit [_] VisitorsRuntime.map + method visit_assign_global : 'env -> assign_global -> assign_global = fun _ x -> x + method visit_place : 'env -> place -> place = fun _ x -> x method visit_rvalue : 'env -> rvalue -> rvalue = fun _ x -> x @@ -118,6 +142,7 @@ class ['self] map_statement_base = type statement = | Assign of place * rvalue + | AssignGlobal of assign_global | FakeRead of place | SetDiscriminant of place * VariantId.id | Drop of place diff --git a/src/LlbcAstUtils.ml b/src/LlbcAstUtils.ml index bc4236cf..84e8e00f 100644 --- a/src/LlbcAstUtils.ml +++ b/src/LlbcAstUtils.ml @@ -1,6 +1,5 @@ open LlbcAst open Utils -open FunIdentifier module T = Types (** Check if a [statement] contains loops *) diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml index 14333088..a074ed1e 100644 --- a/src/LlbcOfJson.ml +++ b/src/LlbcOfJson.ml @@ -11,7 +11,6 @@ open Yojson.Basic open Names open OfJsonBasic -open FunIdentifier module T = Types module V = Values module S = Scalars @@ -19,6 +18,7 @@ module M = Modules module E = Expressions module A = LlbcAst module TU = TypesUtils +module AU = LlbcAstUtils (* The default logger *) let log = Logging.llbc_of_json_logger @@ -227,14 +227,6 @@ let type_decl_of_json (js : json) : (T.type_decl, string) result = } | _ -> Error "") -(* Converts a global ID to its corresponding function ID. - To do so, it adds the global ID to the number of function declarations. -*) -let global_id_of_json (js: json) (fun_count: int) : (FunDeclId.id, string) result = - combine_error_msgs js "global_id_of_json" - (let* gid = FunDeclId.id_of_json js in - Ok (FunDeclId.of_int ((FunDeclId.to_int gid) + fun_count))) - let var_of_json (js : json) : (A.var, string) result = combine_error_msgs js "var_of_json" (match js with @@ -308,23 +300,6 @@ let scalar_value_of_json (js : json) : (V.scalar_value, string) result = raise (Failure ("Scalar value not in range: " ^ V.show_scalar_value sv))); res -let constant_value_of_json (js : json) : (V.constant_value, string) result = - combine_error_msgs js "constant_value_of_json" - (match js with - | `Assoc [ ("Scalar", scalar_value) ] -> - let* scalar_value = scalar_value_of_json scalar_value in - Ok (V.Scalar scalar_value) - | `Assoc [ ("Bool", v) ] -> - let* v = bool_of_json v in - Ok (V.Bool v) - | `Assoc [ ("Char", v) ] -> - let* v = char_of_json v in - Ok (V.Char v) - | `Assoc [ ("String", v) ] -> - let* v = string_of_json v in - Ok (V.String v) - | _ -> Error "") - let field_proj_kind_of_json (js : json) : (E.field_proj_kind, string) result = combine_error_msgs js "field_proj_kind_of_json" (match js with @@ -403,25 +378,30 @@ let binop_of_json (js : json) : (E.binop, string) result = | `String "Shr" -> Ok E.Shr | _ -> Error ("binop_of_json failed on:" ^ show js) -let rec operand_constant_value_of_json (js : json) (fun_count : int) : - (E.operand_constant_value, string) result = - combine_error_msgs js "operand_constant_value_of_json" +let constant_value_of_json (js : json) : (V.constant_value, string) result = + combine_error_msgs js "constant_value_of_json" (match js with + (* This indirection is because Charon still export the type OperandConstantValue, + * which had other variants than ConstantValue before. + *) | `Assoc [ ("ConstantValue", `List [ cv ]) ] -> - let* cv = constant_value_of_json cv in - Ok (E.ConstantValue cv) - | `Assoc [ ("ConstantAdt", `List [ variant_id; field_values ]) ] -> - let* variant_id = option_of_json T.VariantId.id_of_json variant_id in - let* field_values = - list_of_json (fun js -> operand_constant_value_of_json js fun_count) field_values - in - Ok (E.ConstantAdt (variant_id, field_values)) - | `Assoc [ ("ConstantIdentifier", `List [gid]) ] -> - let* id = global_id_of_json gid fun_count in - Ok (E.ConstantId id) - | _ -> Error "") - -let operand_of_json (js : json) (fun_count : int) : (E.operand, string) result = + (match cv with + | `Assoc [ ("Scalar", scalar_value) ] -> + let* scalar_value = scalar_value_of_json scalar_value in + Ok (V.Scalar scalar_value) + | `Assoc [ ("Bool", v) ] -> + let* v = bool_of_json v in + Ok (V.Bool v) + | `Assoc [ ("Char", v) ] -> + let* v = char_of_json v in + Ok (V.Char v) + | `Assoc [ ("String", v) ] -> + let* v = string_of_json v in + Ok (V.String v) + | _ -> Error "") + | _ -> Error "") + +let operand_of_json (js : json) : (E.operand, string) result = combine_error_msgs js "operand_of_json" (match js with | `Assoc [ ("Copy", place) ] -> @@ -432,7 +412,7 @@ let operand_of_json (js : json) (fun_count : int) : (E.operand, string) result = Ok (E.Move place) | `Assoc [ ("Const", `List [ ty; cv ]) ] -> let* ty = ety_of_json ty in - let* cv = operand_constant_value_of_json cv fun_count in + let* cv = constant_value_of_json cv in Ok (E.Constant (ty, cv)) | _ -> Error "") @@ -455,11 +435,11 @@ let aggregate_kind_of_json (js : json) : (E.aggregate_kind, string) result = Ok (E.AggregatedAdt (id, opt_variant_id, regions, tys)) | _ -> Error "") -let rvalue_of_json (js : json) (fun_count : int) : (E.rvalue, string) result = +let rvalue_of_json (js : json) : (E.rvalue, string) result = combine_error_msgs js "rvalue_of_json" (match js with | `Assoc [ ("Use", op) ] -> - let* op = operand_of_json op fun_count in + let* op = operand_of_json op in Ok (E.Use op) | `Assoc [ ("Ref", `List [ place; borrow_kind ]) ] -> let* place = place_of_json place in @@ -467,19 +447,19 @@ let rvalue_of_json (js : json) (fun_count : int) : (E.rvalue, string) result = Ok (E.Ref (place, borrow_kind)) | `Assoc [ ("UnaryOp", `List [ unop; op ]) ] -> let* unop = unop_of_json unop in - let* op = operand_of_json op fun_count in + let* op = operand_of_json op in Ok (E.UnaryOp (unop, op)) | `Assoc [ ("BinaryOp", `List [ binop; op1; op2 ]) ] -> let* binop = binop_of_json binop in - let* op1 = operand_of_json op1 fun_count in - let* op2 = operand_of_json op2 fun_count in + let* op1 = operand_of_json op1 in + let* op2 = operand_of_json op2 in Ok (E.BinaryOp (binop, op1, op2)) | `Assoc [ ("Discriminant", place) ] -> let* place = place_of_json place in Ok (E.Discriminant place) | `Assoc [ ("Aggregate", `List [ aggregate_kind; ops ]) ] -> let* aggregate_kind = aggregate_kind_of_json aggregate_kind in - let* ops = list_of_json (fun js -> operand_of_json js fun_count) ops in + let* ops = list_of_json operand_of_json ops in Ok (E.Aggregate (aggregate_kind, ops)) | _ -> Error "") @@ -502,18 +482,18 @@ let fun_id_of_json (js : json) : (A.fun_id, string) result = combine_error_msgs js "fun_id_of_json" (match js with | `Assoc [ ("Regular", id) ] -> - let* id = FunDeclId.id_of_json id in + let* id = A.FunDeclId.id_of_json id in Ok (A.Regular id) | `Assoc [ ("Assumed", fid) ] -> let* fid = assumed_fun_id_of_json fid in Ok (A.Assumed fid) | _ -> Error "") -let assertion_of_json (js : json) (fun_count : int) : (A.assertion, string) result = +let assertion_of_json (js : json) : (A.assertion, string) result = combine_error_msgs js "assertion_of_json" (match js with | `Assoc [ ("cond", cond); ("expected", expected) ] -> - let* cond = operand_of_json cond fun_count in + let* cond = operand_of_json cond in let* expected = bool_of_json expected in Ok { A.cond; expected } | _ -> Error "") @@ -547,7 +527,7 @@ let fun_sig_of_json (js : json) : (A.fun_sig, string) result = } | _ -> Error "") -let call_of_json (js : json) (fun_count : int) : (A.call, string) result = +let call_of_json (js : json) : (A.call, string) result = combine_error_msgs js "call_of_json" (match js with | `Assoc @@ -561,18 +541,22 @@ let call_of_json (js : json) (fun_count : int) : (A.call, string) result = let* func = fun_id_of_json func in let* region_args = list_of_json erased_region_of_json region_args in let* type_args = list_of_json ety_of_json type_args in - let* args = list_of_json (fun js -> operand_of_json js fun_count) args in + let* args = list_of_json operand_of_json args in let* dest = place_of_json dest in Ok { A.func; region_args; type_args; args; dest } | _ -> Error "") -let rec statement_of_json (js : json) (fun_count : int) : (A.statement, string) result = +let rec statement_of_json (js : json) (gid_conv : A.global_id_converter) : (A.statement, string) result = combine_error_msgs js "statement_of_json" (match js with | `Assoc [ ("Assign", `List [ place; rvalue ]) ] -> let* place = place_of_json place in - let* rvalue = rvalue_of_json rvalue fun_count in + let* rvalue = rvalue_of_json rvalue in Ok (A.Assign (place, rvalue)) + | `Assoc [ ("AssignGlobal", `List [ dst; global ]) ] -> + let* dst = V.VarId.id_of_json dst in + let* global = A.GlobalDeclId.id_of_json global in + Ok (A.AssignGlobal { dst; global }) | `Assoc [ ("FakeRead", place) ] -> let* place = place_of_json place in Ok (A.FakeRead place) @@ -584,10 +568,10 @@ let rec statement_of_json (js : json) (fun_count : int) : (A.statement, string) let* place = place_of_json place in Ok (A.Drop place) | `Assoc [ ("Assert", assertion) ] -> - let* assertion = assertion_of_json assertion fun_count in + let* assertion = assertion_of_json assertion in Ok (A.Assert assertion) | `Assoc [ ("Call", call) ] -> - let* call = call_of_json call fun_count in + let* call = call_of_json call in Ok (A.Call call) | `String "Panic" -> Ok A.Panic | `String "Return" -> Ok A.Return @@ -599,48 +583,48 @@ let rec statement_of_json (js : json) (fun_count : int) : (A.statement, string) Ok (A.Continue i) | `String "Nop" -> Ok A.Nop | `Assoc [ ("Sequence", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json st1 fun_count in - let* st2 = statement_of_json st2 fun_count in + let* st1 = statement_of_json st1 gid_conv in + let* st2 = statement_of_json st2 gid_conv in Ok (A.Sequence (st1, st2)) | `Assoc [ ("Switch", `List [ op; tgt ]) ] -> - let* op = operand_of_json op fun_count in - let* tgt = switch_targets_of_json tgt fun_count in + let* op = operand_of_json op in + let* tgt = switch_targets_of_json tgt gid_conv in Ok (A.Switch (op, tgt)) | `Assoc [ ("Loop", st) ] -> - let* st = statement_of_json st fun_count in + let* st = statement_of_json st gid_conv in Ok (A.Loop st) | _ -> Error "") -and switch_targets_of_json (js : json) (fun_count : int) : (A.switch_targets, string) result = +and switch_targets_of_json (js : json) (gid_conv : A.global_id_converter) : (A.switch_targets, string) result = combine_error_msgs js "switch_targets_of_json" (match js with | `Assoc [ ("If", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json st1 fun_count in - let* st2 = statement_of_json st2 fun_count in + let* st1 = statement_of_json st1 gid_conv in + let* st2 = statement_of_json st2 gid_conv in Ok (A.If (st1, st2)) | `Assoc [ ("SwitchInt", `List [ int_ty; tgts; otherwise ]) ] -> let* int_ty = integer_type_of_json int_ty in let* tgts = list_of_json (pair_of_json (list_of_json scalar_value_of_json) - (fun js -> statement_of_json js fun_count)) + (fun js -> statement_of_json js gid_conv)) tgts in - let* otherwise = statement_of_json otherwise fun_count in + let* otherwise = statement_of_json otherwise gid_conv in Ok (A.SwitchInt (int_ty, tgts, otherwise)) | _ -> Error "") -let fun_body_of_json (js : json) (fun_count : int) : (A.fun_body, string) result = +let fun_body_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_body, string) result = combine_error_msgs js "fun_body_of_json" (match js with | `Assoc [ ("arg_count", arg_count); ("locals", locals); ("body", body) ] -> let* arg_count = int_of_json arg_count in let* locals = list_of_json var_of_json locals in - let* body = statement_of_json body fun_count in + let* body = statement_of_json body gid_conv in Ok { A.arg_count; locals; body } | _ -> Error "") -let fun_decl_of_json (js : json) (fun_count : int) : (A.fun_decl, string) result = +let fun_decl_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_decl, string) result = combine_error_msgs js "fun_decl_of_json" (match js with | `Assoc @@ -650,20 +634,16 @@ let fun_decl_of_json (js : json) (fun_count : int) : (A.fun_decl, string) result ("signature", signature); ("body", body); ] -> - let* def_id = FunDeclId.id_of_json def_id in + let* def_id = A.FunDeclId.id_of_json def_id in let* name = fun_name_of_json name in let* signature = fun_sig_of_json signature in - let* body = option_of_json (fun js -> fun_body_of_json js fun_count) body in + let* body = option_of_json (fun js -> fun_body_of_json js gid_conv) body in Ok { A.def_id; name; signature; body; is_global = false; } | _ -> Error "") - (* Converts a global declaration to a function declaration. - -A.fun_sig -ety_no_regions_to_rty -*) -let global_decl_of_json (js : json) (fun_count: int) : (A.fun_decl, string) result = + *) +let global_decl_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_decl, string) result = combine_error_msgs js "global_decl_of_json" (match js with | `Assoc @@ -673,10 +653,11 @@ let global_decl_of_json (js : json) (fun_count: int) : (A.fun_decl, string) resu ("type_", type_); ("body", body); ] -> - let* def_id = global_id_of_json def_id fun_count in + let* global_id = A.GlobalDeclId.id_of_json def_id in + let def_id = A.global_to_fun_id gid_conv global_id in let* name = fun_name_of_json name in let* type_ = ety_of_json type_ in - let* body = option_of_json (fun js -> fun_body_of_json js fun_count) body in + let* body = option_of_json (fun js -> fun_body_of_json js gid_conv) body in let signature : A.fun_sig = { region_params = []; num_early_bound_regions = 0; @@ -708,14 +689,17 @@ let type_declaration_group_of_json (js : json) : let fun_declaration_group_of_json (js : json) : (M.fun_declaration_group, string) result = combine_error_msgs js "fun_declaration_group_of_json" - (g_declaration_group_of_json FunDeclId.id_of_json js) + (g_declaration_group_of_json A.FunDeclId.id_of_json js) -let global_declaration_group_of_json (js : json) (fun_count: int) : +let global_declaration_group_of_json (js : json) (gid_conv : A.global_id_converter) : (M.fun_declaration_group, string) result = combine_error_msgs js "global_declaration_group_of_json" - (g_declaration_group_of_json (fun js -> global_id_of_json js fun_count) js) + (g_declaration_group_of_json (fun js -> + let* id = A.GlobalDeclId.id_of_json js in + Ok (A.global_to_fun_id gid_conv id) + ) js) -let declaration_group_of_json (js : json) (fun_count: int) : (M.declaration_group, string) result +let declaration_group_of_json (js : json) (gid_conv : A.global_id_converter) : (M.declaration_group, string) result = combine_error_msgs js "declaration_of_json" (match js with @@ -726,7 +710,7 @@ let declaration_group_of_json (js : json) (fun_count: int) : (M.declaration_grou let* decl = fun_declaration_group_of_json decl in Ok (M.Fun decl) | `Assoc [ ("Global", `List [ decl ]) ] -> - let* decl = global_declaration_group_of_json decl fun_count in + let* decl = global_declaration_group_of_json decl gid_conv in Ok (M.Fun decl) | _ -> Error "") @@ -748,12 +732,19 @@ let llbc_module_of_json (js : json) : (M.llbc_module, string) result = ("globals", globals); ] -> let* fun_count = length_of_json_list functions in + let gid_conv = { A.fun_count = fun_count } in let* name = string_of_json name in let* declarations = - list_of_json (fun js -> declaration_group_of_json js fun_count) declarations + list_of_json (fun js -> declaration_group_of_json js gid_conv) declarations in let* types = list_of_json type_decl_of_json types in - let* functions = list_of_json (fun js -> fun_decl_of_json js fun_count) functions in - let* globals = list_of_json (fun js -> global_decl_of_json js fun_count) globals in - Ok { M.name; declarations; types; functions = functions @ globals } + let* functions = list_of_json (fun js -> fun_decl_of_json js gid_conv) functions in + let* globals = list_of_json (fun js -> global_decl_of_json js gid_conv) globals in + Ok { + M.name; + declarations; + types; + functions = functions @ globals; + gid_conv; + } | _ -> Error "") diff --git a/src/Modules.ml b/src/Modules.ml index 6d0cf70c..b0e8878d 100644 --- a/src/Modules.ml +++ b/src/Modules.ml @@ -1,6 +1,5 @@ open Types open LlbcAst -open FunIdentifier type 'id g_declaration_group = NonRec of 'id | Rec of 'id list [@@deriving show] @@ -21,6 +20,7 @@ type llbc_module = { declarations : declaration_group list; types : type_decl list; functions : fun_decl list; + gid_conv : global_id_converter; } (** LLBC module - TODO: rename to crate *) diff --git a/src/Print.ml b/src/Print.ml index 9e2ff3cd..722f76ce 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -1,5 +1,4 @@ open Names -open FunIdentifier module T = Types module TU = TypesUtils module V = Values @@ -686,7 +685,8 @@ module LlbcAst = struct var_id_to_string : V.VarId.id -> string; adt_field_names : T.TypeDeclId.id -> T.VariantId.id option -> string list option; - fun_decl_id_to_string : FunDeclId.id -> string; + fun_decl_id_to_string : A.FunDeclId.id -> string; + global_decl_id_to_string : A.GlobalDeclId.id -> string; } let ast_to_ctx_formatter (fmt : ast_formatter) : PC.ctx_formatter = @@ -743,6 +743,9 @@ module LlbcAst = struct let def = C.ctx_lookup_fun_decl ctx def_id in fun_name_to_string def.name in + let global_decl_id_to_string def_id = + fun_decl_id_to_string (A.global_to_fun_id ctx.fun_context.gid_conv def_id) + in { rvar_to_string = ctx_fmt.PV.rvar_to_string; r_to_string = ctx_fmt.PV.r_to_string; @@ -753,10 +756,14 @@ module LlbcAst = struct adt_field_names = ctx_fmt.PV.adt_field_names; adt_field_to_string; fun_decl_id_to_string; + global_decl_id_to_string; } - let fun_decl_to_ast_formatter (type_decls : T.type_decl T.TypeDeclId.Map.t) - (fun_decls : A.fun_decl FunDeclId.Map.t) (fdef : A.fun_decl) : + let fun_decl_to_ast_formatter + (type_decls : T.type_decl T.TypeDeclId.Map.t) + (fun_decls : A.fun_decl A.FunDeclId.Map.t) + (global_to_fun_id : A.GlobalDeclId.id -> A.FunDeclId.id) + (fdef : A.fun_decl) : ast_formatter = let rvar_to_string r = let rvar = T.RegionVarId.nth fdef.signature.region_params r in @@ -782,9 +789,12 @@ module LlbcAst = struct let adt_field_names = PC.type_ctx_to_adt_field_names_fun type_decls in let adt_field_to_string = type_ctx_to_adt_field_to_string_fun type_decls in let fun_decl_id_to_string def_id = - let def = FunDeclId.Map.find def_id fun_decls in + let def = A.FunDeclId.Map.find def_id fun_decls in fun_name_to_string def.name in + let global_decl_id_to_string def_id = + fun_decl_id_to_string (global_to_fun_id def_id) + in { rvar_to_string; r_to_string; @@ -795,6 +805,7 @@ module LlbcAst = struct adt_field_names; adt_field_to_string; fun_decl_id_to_string; + global_decl_id_to_string; } let rec projection_to_string (fmt : ast_formatter) (inside : string) @@ -860,36 +871,13 @@ module LlbcAst = struct | E.Shl -> "<<" | E.Shr -> ">>" - let rec operand_constant_value_to_string (fmt : ast_formatter) - (cv : E.operand_constant_value) : string = - match cv with - | E.ConstantId id -> fmt.fun_decl_id_to_string id - | E.ConstantValue cv -> PV.constant_value_to_string cv - | E.ConstantAdt (variant_id, field_values) -> - (* This is a bit annoying, because we don't have context information - * to convert the ADT to a value, so we do the best we can in the - * simplest manner. Anyway, those printing utilitites are only used - * for debugging, and complex constant values are not common. - * We might want to store type information in the operand constant values - * in the future. - *) - let variant_id = option_to_string T.VariantId.to_string variant_id in - let field_values = - List.map (operand_constant_value_to_string fmt) field_values - in - "ConstantAdt " ^ variant_id ^ " {" - ^ String.concat ", " field_values - ^ "}" - let operand_to_string (fmt : ast_formatter) (op : E.operand) : string = match op with | E.Copy p -> "copy " ^ place_to_string fmt p | E.Move p -> "move " ^ place_to_string fmt p | E.Constant (ty, cv) -> - (* For clarity, we also print the typing information: see the comment in - * [operand_constant_value_to_string] *) "(" - ^ operand_constant_value_to_string fmt cv + ^ PV.constant_value_to_string cv ^ " : " ^ PT.ety_to_string (ast_to_etype_formatter fmt) ty ^ ")" @@ -950,6 +938,8 @@ module LlbcAst = struct match st with | A.Assign (p, rv) -> indent ^ place_to_string fmt p ^ " := " ^ rvalue_to_string fmt rv + | A.AssignGlobal { dst; global } -> + indent ^ fmt.var_id_to_string dst ^ " := global " ^ fmt.global_decl_id_to_string global | A.FakeRead p -> "fake_read " ^ place_to_string fmt p | A.SetDiscriminant (p, variant_id) -> (* TODO: improve this to lookup the variant name by using the def id *) @@ -1139,8 +1129,11 @@ module Module = struct (** Generate an [ast_formatter] by using a definition context in combination with the variables local to a function's definition *) - let def_ctx_to_ast_formatter (type_context : T.type_decl T.TypeDeclId.Map.t) - (fun_context : A.fun_decl FunDeclId.Map.t) (def : A.fun_decl) : + let def_ctx_to_ast_formatter + (type_context : T.type_decl T.TypeDeclId.Map.t) + (fun_context : A.fun_decl A.FunDeclId.Map.t) + (global_to_fun_id : A.GlobalDeclId.id -> A.FunDeclId.id) + (def : A.fun_decl) : PA.ast_formatter = let rvar_to_string vid = let var = T.RegionVarId.nth def.signature.region_params vid in @@ -1159,9 +1152,12 @@ module Module = struct name_to_string def.name in let fun_decl_id_to_string def_id = - let def = FunDeclId.Map.find def_id fun_context in + let def = A.FunDeclId.Map.find def_id fun_context in fun_name_to_string def.name in + let global_decl_id_to_string def_id = + fun_decl_id_to_string (global_to_fun_id def_id) + in let var_id_to_string vid = let var = V.VarId.nth (Option.get def.body).locals vid in PA.var_to_string var @@ -1183,13 +1179,17 @@ module Module = struct var_id_to_string; adt_field_names; fun_decl_id_to_string; + global_decl_id_to_string; } (** This function pretty-prints a function definition by using a definition context *) - let fun_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) - (fun_context : A.fun_decl FunDeclId.Map.t) (def : A.fun_decl) : string = - let fmt = def_ctx_to_ast_formatter type_context fun_context def in + let fun_decl_to_string + (type_context : T.type_decl T.TypeDeclId.Map.t) + (fun_context : A.fun_decl A.FunDeclId.Map.t) + (global_to_fun_id : A.GlobalDeclId.id -> A.FunDeclId.id) + (def : A.fun_decl) : string = + let fmt = def_ctx_to_ast_formatter type_context fun_context global_to_fun_id def in PA.fun_decl_to_string fmt "" " " def let module_to_string (m : M.llbc_module) : string = @@ -1200,7 +1200,8 @@ module Module = struct (* The functions *) let fun_decls = - List.map (fun_decl_to_string types_defs_map funs_defs_map) m.M.functions + let gid_to_fid = fun gid -> A.global_to_fun_id m.gid_conv gid in + List.map (fun_decl_to_string types_defs_map funs_defs_map gid_to_fid) m.M.functions in (* Put everything together *) @@ -1257,11 +1258,6 @@ module EvalCtxLlbcAst = struct let fmt = PC.eval_ctx_to_ctx_formatter ctx in PV.typed_avalue_to_string fmt v - let operand_constant_value_to_string (ctx : C.eval_ctx) - (cv : E.operand_constant_value) : string = - let fmt = PA.eval_ctx_to_ast_formatter ctx in - PA.operand_constant_value_to_string fmt cv - let place_to_string (ctx : C.eval_ctx) (op : E.place) : string = let fmt = PA.eval_ctx_to_ast_formatter ctx in PA.place_to_string fmt op diff --git a/src/PrintPure.ml b/src/PrintPure.ml index 8864dafe..ea9bf2ab 100644 --- a/src/PrintPure.ml +++ b/src/PrintPure.ml @@ -2,7 +2,6 @@ open Pure open PureUtils -open FunIdentifier module T = Types module V = Values module E = Expressions @@ -44,7 +43,7 @@ type ast_formatter = { adt_field_to_string : TypeDeclId.id -> VariantId.id option -> FieldId.id -> string option; adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; - fun_decl_id_to_string : FunDeclId.id -> string; + fun_decl_id_to_string : A.FunDeclId.id -> string; } let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = @@ -86,7 +85,7 @@ let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) while we only need those definitions to lookup proper names for the def ids. *) let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) - (fun_decls : A.fun_decl FunDeclId.Map.t) (type_params : type_var list) : + (fun_decls : A.fun_decl A.FunDeclId.Map.t) (type_params : type_var list) : ast_formatter = let type_var_id_to_string vid = let var = T.TypeVarId.nth type_params vid in @@ -110,7 +109,7 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) Print.LlbcAst.type_ctx_to_adt_field_to_string_fun type_decls in let fun_decl_id_to_string def_id = - let def = FunDeclId.Map.find def_id fun_decls in + let def = A.FunDeclId.Map.find def_id fun_decls in fun_name_to_string def.name in { diff --git a/src/Pure.ml b/src/Pure.ml index 256a872a..42f56fed 100644 --- a/src/Pure.ml +++ b/src/Pure.ml @@ -1,6 +1,5 @@ open Identifiers open Names -open FunIdentifier module T = Types module V = Values module E = Expressions @@ -567,7 +566,7 @@ type fun_body = { } type fun_decl = { - def_id : FunDeclId.id; + def_id : A.FunDeclId.id; back_id : T.RegionGroupId.id option; basename : fun_name; (** The "base" name of the function. diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml index 55a8853a..195eb879 100644 --- a/src/PureToExtract.ml +++ b/src/PureToExtract.ml @@ -6,7 +6,6 @@ open Pure open TranslateCore -open FunIdentifier module C = Contexts module RegionVarId = T.RegionVarId module F = Format @@ -93,7 +92,7 @@ type formatter = { (`None` if forward function) TODO: use the fun id for the assumed functions. *) - decreases_clause_name : FunDeclId.id -> fun_name -> string; + decreases_clause_name : A.FunDeclId.id -> fun_name -> string; (** Generates the name of the definition used to prove/reason about termination. The generated code uses this clause where needed, but its body must be defined by the user. @@ -357,7 +356,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = let fun_name = match fid with | A.Regular fid -> - Print.fun_name_to_string (FunDeclId.Map.find fid fun_decls).name + Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name | A.Assumed aid -> A.show_assumed_fun_id aid in let fun_kind = @@ -370,7 +369,7 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = let fun_name = match fid with | A.Regular fid -> - Print.fun_name_to_string (FunDeclId.Map.find fid fun_decls).name + Print.fun_name_to_string (A.FunDeclId.Map.find fid fun_decls).name | A.Assumed aid -> A.show_assumed_fun_id aid in "decreases clause for function: " ^ fun_name @@ -445,7 +444,7 @@ let ctx_get_function (id : A.fun_id) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = ctx_get (FunId (id, rg)) ctx -let ctx_get_local_function (id : FunDeclId.id) (rg : RegionGroupId.id option) +let ctx_get_local_function (id : A.FunDeclId.id) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = ctx_get_function (A.Regular id) rg ctx @@ -476,7 +475,7 @@ let ctx_get_variant (def_id : type_id) (variant_id : VariantId.id) (ctx : extraction_ctx) : string = ctx_get (VariantId (def_id, variant_id)) ctx -let ctx_get_decreases_clause (def_id : FunDeclId.id) (ctx : extraction_ctx) : +let ctx_get_decreases_clause (def_id : A.FunDeclId.id) (ctx : extraction_ctx) : string = ctx_get (DecreasesClauseId (A.Regular def_id)) ctx @@ -574,7 +573,7 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) (* Lookup the LLBC def to compute the region group information *) let def_id = def.def_id in let llbc_def = - FunDeclId.Map.find def_id ctx.trans_ctx.fun_context.fun_decls + A.FunDeclId.Map.find def_id ctx.trans_ctx.fun_context.fun_decls in let sg = llbc_def.signature in let num_rgs = List.length sg.regions_hierarchy in diff --git a/src/Substitute.ml b/src/Substitute.ml index 711e438b..4b0a04ca 100644 --- a/src/Substitute.ml +++ b/src/Substitute.ml @@ -210,12 +210,6 @@ let place_substitute (_tsubst : T.TypeVarId.id -> T.ety) (p : E.place) : E.place (* There is nothing to do *) p -(** Apply a type substitution to an operand constant value *) -let operand_constant_value_substitute (_tsubst : T.TypeVarId.id -> T.ety) - (op : E.operand_constant_value) : E.operand_constant_value = - (* There is nothing to do *) - op - (** Apply a type substitution to an operand *) let operand_substitute (tsubst : T.TypeVarId.id -> T.ety) (op : E.operand) : E.operand = @@ -225,9 +219,7 @@ let operand_substitute (tsubst : T.TypeVarId.id -> T.ety) (op : E.operand) : | E.Move p -> E.Move (p_subst p) | E.Constant (ety, cv) -> let rsubst x = x in - E.Constant - ( ty_substitute rsubst tsubst ety, - operand_constant_value_substitute tsubst cv ) + E.Constant ( ty_substitute rsubst tsubst ety, cv ) (** Apply a type substitution to an rvalue *) let rvalue_substitute (tsubst : T.TypeVarId.id -> T.ety) (rv : E.rvalue) : @@ -289,6 +281,7 @@ let rec statement_substitute (tsubst : T.TypeVarId.id -> T.ety) let p = place_substitute tsubst p in let rvalue = rvalue_substitute tsubst rvalue in A.Assign (p, rvalue) + | A.AssignGlobal g -> A.AssignGlobal g | A.FakeRead p -> let p = place_substitute tsubst p in A.FakeRead p diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml index 2b416cc1..927684bc 100644 --- a/src/SymbolicToPure.ml +++ b/src/SymbolicToPure.ml @@ -2,7 +2,6 @@ open Errors open LlbcAstUtils open Pure open PureUtils -open FunIdentifier module Id = Identifiers module M = Modules module S = SymbolicAst @@ -68,9 +67,10 @@ type fun_sig_named_outputs = { } type fun_context = { - llbc_fun_decls : A.fun_decl FunDeclId.Map.t; + llbc_fun_decls : A.fun_decl A.FunDeclId.Map.t; fun_sigs : fun_sig_named_outputs RegularFunIdMap.t; (** *) - fun_infos : FA.fun_info FunDeclId.Map.t; + fun_infos : FA.fun_info A.FunDeclId.Map.t; + gid_conv : A.global_id_converter; } type call_info = { @@ -134,8 +134,11 @@ let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = (* TODO: move *) let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.LlbcAst.ast_formatter = - Print.LlbcAst.fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls - ctx.fun_context.llbc_fun_decls ctx.fun_decl + Print.LlbcAst.fun_decl_to_ast_formatter + ctx.type_context.llbc_type_decls + ctx.fun_context.llbc_fun_decls + (A.global_to_fun_id ctx.fun_context.gid_conv) + ctx.fun_decl let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = let type_params = ctx.fun_decl.signature.type_params in @@ -196,12 +199,12 @@ let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : T.type_decl = TypeDeclId.Map.find id ctx.type_context.llbc_type_decls -let bs_ctx_lookup_llbc_fun_decl (id : FunDeclId.id) (ctx : bs_ctx) : A.fun_decl +let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : A.fun_decl = - FunDeclId.Map.find id ctx.fun_context.llbc_fun_decls + A.FunDeclId.Map.find id ctx.fun_context.llbc_fun_decls (* TODO: move *) -let bs_ctx_lookup_local_function_sig (def_id : FunDeclId.id) +let bs_ctx_lookup_local_function_sig (def_id : A.FunDeclId.id) (back_id : T.RegionGroupId.id option) (ctx : bs_ctx) : fun_sig = let id = (A.Regular def_id, back_id) in (RegularFunIdMap.find id ctx.fun_context.fun_sigs).sg @@ -472,11 +475,11 @@ let list_ancestor_abstractions (ctx : bs_ctx) (abs : V.abs) : List.map (fun id -> V.AbstractionId.Map.find id ctx.abstractions) abs_ids (** Small utility. *) -let get_fun_effect_info (fun_infos : FA.fun_info FunDeclId.Map.t) +let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id) (gid : T.RegionGroupId.id option) : fun_effect_info = match fun_id with | A.Regular fid -> - let info = FunDeclId.Map.find fid fun_infos in + let info = A.FunDeclId.Map.find fid fun_infos in let input_state = info.stateful in let output_state = input_state && gid = None in { can_fail = true; input_state; output_state } @@ -494,7 +497,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info FunDeclId.Map.t) name (outputs for backward functions come from borrows in the inputs of the forward function). *) -let translate_fun_sig (fun_infos : FA.fun_info FunDeclId.Map.t) +let translate_fun_sig (fun_infos : FA.fun_info A.FunDeclId.Map.t) (fun_id : A.fun_id) (types_infos : TA.type_infos) (sg : A.fun_sig) (input_names : string option list) (bid : T.RegionGroupId.id option) : fun_sig_named_outputs = @@ -1744,7 +1747,7 @@ let translate_type_decls (type_decls : T.type_decl list) : type_decl list = - optional names for the outputs values (we derive them for the backward functions) *) -let translate_fun_signatures (fun_infos : FA.fun_info FunDeclId.Map.t) +let translate_fun_signatures (fun_infos : FA.fun_info A.FunDeclId.Map.t) (types_infos : TA.type_infos) (functions : (A.fun_id * string option list * A.fun_sig) list) : fun_sig_named_outputs RegularFunIdMap.t = diff --git a/src/Translate.ml b/src/Translate.ml index 1577753c..d4d79355 100644 --- a/src/Translate.ml +++ b/src/Translate.ml @@ -1,6 +1,5 @@ open InterpreterStatements open Interpreter -open FunIdentifier module L = Logging module T = Types module A = LlbcAst @@ -65,7 +64,10 @@ let translate_function_to_symbolics (config : C.partial_config) ^ Print.fun_name_to_string fdef.A.name)); let { type_context; fun_context } = trans_ctx in - let fun_context = { C.fun_decls = fun_context.fun_decls } in + let fun_context = { + C.fun_decls = fun_context.fun_decls; + C.gid_conv = fun_context.gid_conv; + } in match fdef.body with | None -> None @@ -100,7 +102,8 @@ let translate_function_to_symbolics (config : C.partial_config) let translate_function_to_pure (config : C.partial_config) (mp_config : Micro.config) (trans_ctx : trans_ctx) (fun_sigs : SymbolicToPure.fun_sig_named_outputs RegularFunIdMap.t) - (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fdef : A.fun_decl) + (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) + (fdef : A.fun_decl) : pure_fun_translation = (* Debug *) log#ldebug @@ -139,6 +142,7 @@ let translate_function_to_pure (config : C.partial_config) SymbolicToPure.llbc_fun_decls = fun_context.fun_decls; fun_sigs; fun_infos = fun_context.fun_infos; + gid_conv = fun_context.gid_conv; } in let ctx = @@ -291,7 +295,11 @@ let translate_module_to_pure (config : C.partial_config) (* Compute the type and function contexts *) let type_context, fun_context = compute_type_fun_contexts m in let fun_infos = FA.analyze_module m fun_context.C.fun_decls use_state in - let fun_context = { fun_decls = fun_context.fun_decls; fun_infos } in + let fun_context = { + fun_decls = fun_context.fun_decls; + fun_infos; + gid_conv = m.gid_conv; + } in let trans_ctx = { type_context; fun_context } in (* Translate all the type definitions *) @@ -352,8 +360,8 @@ type gen_ctx = { m : M.llbc_module; extract_ctx : PureToExtract.extraction_ctx; trans_types : Pure.type_decl Pure.TypeDeclId.Map.t; - trans_funs : (bool * pure_fun_translation) FunDeclId.Map.t; - functions_with_decreases_clause : FunDeclId.Set.t; + trans_funs : (bool * pure_fun_translation) A.FunDeclId.Map.t; + functions_with_decreases_clause : A.FunDeclId.Set.t; } (** Extraction context *) @@ -389,7 +397,7 @@ let module_has_opaque_decls (ctx : gen_ctx) : bool * bool = ctx.trans_types in let has_opaque_funs = - FunDeclId.Map.exists + A.FunDeclId.Map.exists (fun _ ((_, (t_fwd, _)) : bool * pure_fun_translation) -> Option.is_none t_fwd.body) ctx.trans_funs @@ -428,7 +436,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) (* Utility to check a function has a decrease clause *) let has_decreases_clause (def : Pure.fun_decl) : bool = - FunDeclId.Set.mem def.def_id ctx.functions_with_decreases_clause + A.FunDeclId.Set.mem def.def_id ctx.functions_with_decreases_clause in (* In case of (non-mutually) recursive functions, we use a simple procedure to @@ -524,14 +532,14 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) ids | Fun (NonRec id) -> (* Lookup *) - let pure_fun = FunDeclId.Map.find id ctx.trans_funs in + let pure_fun = A.FunDeclId.Map.find id ctx.trans_funs in (* Translate *) export_functions false [ pure_fun ] | Fun (Rec ids) -> (* General case of mutually recursive functions *) (* Lookup *) let pure_funs = - List.map (fun id -> FunDeclId.Map.find id ctx.trans_funs) ids + List.map (fun id -> A.FunDeclId.Map.find id ctx.trans_funs) ids in (* Translate *) export_functions true pure_funs @@ -623,7 +631,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) (* We need to compute which functions are recursive, in order to know * whether we should generate a decrease clause or not. *) let rec_functions = - FunDeclId.Set.of_list + A.FunDeclId.Set.of_list (List.concat (List.map (fun decl -> match decl with M.Fun (Rec ids) -> ids | _ -> []) @@ -645,7 +653,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) (fun ctx (keep_fwd, def) -> (* Note that we generate a decrease clause for all the recursive functions *) let gen_decr_clause = - FunDeclId.Set.mem (fst def).Pure.def_id rec_functions + A.FunDeclId.Set.mem (fst def).Pure.def_id rec_functions in ExtractToFStar.extract_fun_decl_register_names ctx keep_fwd gen_decr_clause def) @@ -675,7 +683,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) (List.map (fun (d : Pure.type_decl) -> (d.def_id, d)) trans_types) in let trans_funs = - FunDeclId.Map.of_list + A.FunDeclId.Map.of_list (List.map (fun ((keep_fwd, (fd, bdl)) : bool * pure_fun_translation) -> (fd.def_id, (keep_fwd, (fd, bdl)))) @@ -762,7 +770,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) (* Extract the template clauses *) let needs_clauses_module = config.extract_decreases_clauses - && not (FunDeclId.Set.is_empty rec_functions) + && not (A.FunDeclId.Set.is_empty rec_functions) in (if needs_clauses_module && config.extract_template_decreases_clauses then let clauses_filename = extract_filebasename ^ ".Clauses.Template.fst" in diff --git a/src/TranslateCore.ml b/src/TranslateCore.ml index 3d3887ce..ccaa9e22 100644 --- a/src/TranslateCore.ml +++ b/src/TranslateCore.ml @@ -1,7 +1,6 @@ (** Some utilities for the translation *) open InterpreterStatements -open FunIdentifier module L = Logging module T = Types module A = LlbcAst @@ -15,8 +14,9 @@ let log = L.translate_log type type_context = C.type_context [@@deriving show] type fun_context = { - fun_decls : A.fun_decl FunDeclId.Map.t; - fun_infos : FA.fun_info FunDeclId.Map.t; + fun_decls : A.fun_decl A.FunDeclId.Map.t; + fun_infos : FA.fun_info A.FunDeclId.Map.t; + gid_conv : A.global_id_converter; } [@@deriving show] @@ -50,6 +50,6 @@ let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = let fmt = PrintPure.mk_ast_formatter type_decls fun_decls type_params in PrintPure.fun_decl_to_string fmt def -let fun_decl_id_to_string (ctx : trans_ctx) (id : FunDeclId.id) : string = +let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = Print.fun_name_to_string - (FunDeclId.Map.find id ctx.fun_context.fun_decls).name + (A.FunDeclId.Map.find id ctx.fun_context.fun_decls).name diff --git a/src/main.ml b/src/main.ml index 6b1083f5..93b094fd 100644 --- a/src/main.ml +++ b/src/main.ml @@ -124,21 +124,21 @@ let () = * command-line arguments *) (* By setting a level for the main_logger_handler, we filter everything *) Easy_logging.Handlers.set_level main_logger_handler EL.Debug; - main_log#set_level EL.Info; - llbc_of_json_logger#set_level EL.Info; - pre_passes_log#set_level EL.Info; - interpreter_log#set_level EL.Info; - statements_log#set_level EL.Info; - paths_log#set_level EL.Info; - expressions_log#set_level EL.Info; - expansion_log#set_level EL.Info; - borrows_log#set_level EL.Info; - invariants_log#set_level EL.Info; - pure_utils_log#set_level EL.Info; - symbolic_to_pure_log#set_level EL.Info; - pure_micro_passes_log#set_level EL.Info; - pure_to_extract_log#set_level EL.Info; - translate_log#set_level EL.Info; + main_log#set_level EL.Debug; + llbc_of_json_logger#set_level EL.Debug; + pre_passes_log#set_level EL.Debug; + interpreter_log#set_level EL.Debug; + statements_log#set_level EL.Debug; + paths_log#set_level EL.Debug; + expressions_log#set_level EL.Debug; + expansion_log#set_level EL.Debug; + borrows_log#set_level EL.Debug; + invariants_log#set_level EL.Debug; + pure_utils_log#set_level EL.Debug; + symbolic_to_pure_log#set_level EL.Debug; + pure_micro_passes_log#set_level EL.Debug; + pure_to_extract_log#set_level EL.Debug; + translate_log#set_level EL.Debug; (* Load the module *) let json = Yojson.Basic.from_file filename in match llbc_module_of_json json with -- cgit v1.2.3 From da118da3e590fbea4e880121837da2ee938837f6 Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Thu, 23 Jun 2022 15:43:49 +0200 Subject: adapt to new LLBC (without OperandConstantValue) --- src/LlbcOfJson.ml | 30 ++++++++++++------------------ src/main.ml | 30 +++++++++++++++--------------- 2 files changed, 27 insertions(+), 33 deletions(-) (limited to 'src') diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml index a074ed1e..3ff45077 100644 --- a/src/LlbcOfJson.ml +++ b/src/LlbcOfJson.ml @@ -381,24 +381,18 @@ let binop_of_json (js : json) : (E.binop, string) result = let constant_value_of_json (js : json) : (V.constant_value, string) result = combine_error_msgs js "constant_value_of_json" (match js with - (* This indirection is because Charon still export the type OperandConstantValue, - * which had other variants than ConstantValue before. - *) - | `Assoc [ ("ConstantValue", `List [ cv ]) ] -> - (match cv with - | `Assoc [ ("Scalar", scalar_value) ] -> - let* scalar_value = scalar_value_of_json scalar_value in - Ok (V.Scalar scalar_value) - | `Assoc [ ("Bool", v) ] -> - let* v = bool_of_json v in - Ok (V.Bool v) - | `Assoc [ ("Char", v) ] -> - let* v = char_of_json v in - Ok (V.Char v) - | `Assoc [ ("String", v) ] -> - let* v = string_of_json v in - Ok (V.String v) - | _ -> Error "") + | `Assoc [ ("Scalar", scalar_value) ] -> + let* scalar_value = scalar_value_of_json scalar_value in + Ok (V.Scalar scalar_value) + | `Assoc [ ("Bool", v) ] -> + let* v = bool_of_json v in + Ok (V.Bool v) + | `Assoc [ ("Char", v) ] -> + let* v = char_of_json v in + Ok (V.Char v) + | `Assoc [ ("String", v) ] -> + let* v = string_of_json v in + Ok (V.String v) | _ -> Error "") let operand_of_json (js : json) : (E.operand, string) result = diff --git a/src/main.ml b/src/main.ml index 93b094fd..6b1083f5 100644 --- a/src/main.ml +++ b/src/main.ml @@ -124,21 +124,21 @@ let () = * command-line arguments *) (* By setting a level for the main_logger_handler, we filter everything *) Easy_logging.Handlers.set_level main_logger_handler EL.Debug; - main_log#set_level EL.Debug; - llbc_of_json_logger#set_level EL.Debug; - pre_passes_log#set_level EL.Debug; - interpreter_log#set_level EL.Debug; - statements_log#set_level EL.Debug; - paths_log#set_level EL.Debug; - expressions_log#set_level EL.Debug; - expansion_log#set_level EL.Debug; - borrows_log#set_level EL.Debug; - invariants_log#set_level EL.Debug; - pure_utils_log#set_level EL.Debug; - symbolic_to_pure_log#set_level EL.Debug; - pure_micro_passes_log#set_level EL.Debug; - pure_to_extract_log#set_level EL.Debug; - translate_log#set_level EL.Debug; + main_log#set_level EL.Info; + llbc_of_json_logger#set_level EL.Info; + pre_passes_log#set_level EL.Info; + interpreter_log#set_level EL.Info; + statements_log#set_level EL.Info; + paths_log#set_level EL.Info; + expressions_log#set_level EL.Info; + expansion_log#set_level EL.Info; + borrows_log#set_level EL.Info; + invariants_log#set_level EL.Info; + pure_utils_log#set_level EL.Info; + symbolic_to_pure_log#set_level EL.Info; + pure_micro_passes_log#set_level EL.Info; + pure_to_extract_log#set_level EL.Info; + translate_log#set_level EL.Info; (* Load the module *) let json = Yojson.Basic.from_file filename in match llbc_module_of_json json with -- cgit v1.2.3 From 47691de8fe3dc32a29663d4d8343eb415ce1d81e Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Thu, 30 Jun 2022 12:22:14 +0200 Subject: Traduct globals body separately (WIP) --- src/ExtractToFStar.ml | 129 ++++++++++++++++++++++++++++++++++++++++++++----- src/FunsAnalysis.ml | 77 ++++++++++++++++------------- src/Modules.ml | 3 +- src/PrintPure.ml | 10 +++- src/Pure.ml | 3 +- src/PureMicroPasses.ml | 5 +- src/PureToExtract.ml | 18 +++++-- src/PureTypeCheck.ml | 2 +- src/SymbolicToPure.ml | 14 ++++-- src/Translate.ml | 7 +-- src/TranslateCore.ml | 6 ++- 11 files changed, 208 insertions(+), 66 deletions(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index b89579b5..20b06bfa 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -26,6 +26,14 @@ type type_decl_qualif = *) type fun_decl_qualif = Let | LetRec | And | Val | AssumeVal +let fun_decl_qualif_name (qualif : fun_decl_qualif) : string = + match qualif with + | Let -> "let" + | LetRec -> "let rec" + | And -> "and" + | Val -> "val" + | AssumeVal -> "assume val" + (** Small helper to compute the name of an int type *) let fstar_int_name (int_ty : integer_type) = match int_ty with @@ -305,11 +313,11 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) (* Concatenate the elements *) String.concat "_" fname in - let fun_name (_fid : A.fun_id) (fname : fun_name) (num_rgs : int) + let fun_name (_fid : A.fun_id) (fname : fun_name) (is_global : bool) (num_rgs : int) (rg : region_group_info option) (filter_info : bool * int) : string = let fname = fun_name_to_snake_case fname in (* Compute the suffix *) - let suffix = default_fun_suffix num_rgs rg filter_info in + let suffix = default_fun_suffix is_global num_rgs rg filter_info in (* Concatenate *) fname ^ suffix in @@ -898,12 +906,14 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) match qualif.id with | Func fun_id -> extract_function_call ctx fmt inside fun_id qualif.type_args args + | Global global_id -> + let fid = A.global_to_fun_id ctx.trans_ctx.fun_context.gid_conv global_id in + let fun_id = Regular (A.Regular fid, None) in + extract_function_call ctx fmt inside fun_id qualif.type_args args | AdtCons adt_cons_id -> extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args args | Proj proj -> extract_field_projector ctx fmt inside app proj qualif.type_args args - (* TODO | Global global_id -> - extract_global_ref ctx fmt inside global_id*) ) | _ -> (* "Regular" expression *) @@ -1358,14 +1368,7 @@ let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_open_hovbox fmt ctx.indent_incr; (* > "let FUN_NAME" *) let is_opaque = Option.is_none def.body in - let qualif = - match qualif with - | Let -> "let" - | LetRec -> "let rec" - | And -> "and" - | Val -> "val" - | AssumeVal -> "assume val" - in + let qualif = fun_decl_qualif_name qualif in F.pp_print_string fmt (qualif ^ " " ^ def_name); F.pp_print_space fmt (); (* Open a box for "(PARAMS) : EFFECT =" *) @@ -1474,6 +1477,108 @@ let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 +(* Change the suffix from "_c" to "_body" *) +let global_decl_to_body_name (decl : string) : string = + (* The declaration length without the global suffix *) + let base_len = String.length decl - 2 in + (* TODO: Use String.ends_with instead when a more recent version of OCaml is used *) + assert (String.sub decl base_len 2 = "_c"); + (String.sub decl 0 base_len) ^ "_body" + +(** Print a definition of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) +let extract_global_definition (ctx : extraction_ctx) (fmt : F.formatter) + (qualif : fun_decl_qualif) (name : string) (ty : ty) + (extract_body : (F.formatter -> unit) Option.t) + : unit = + let is_opaque = Option.is_none extract_body in + + (* Open the definition box (depth=0) *) + F.pp_open_hvbox fmt ctx.indent_incr; + + (* Open "QUALIF NAME : TYPE =" box (depth=1) *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print "QUALIF NAME " *) + F.pp_print_string fmt (fun_decl_qualif_name qualif ^ " " ^ name); + F.pp_print_space fmt (); + + (* Open ": TYPE =" box (depth=2) *) + F.pp_open_hvbox fmt 0; + (* Print ": " *) + F.pp_print_string fmt ":"; + F.pp_print_space fmt (); + + (* Open "TYPE" box (depth=3) *) + F.pp_open_hovbox fmt ctx.indent_incr; + (* Print "TYPE" *) + extract_ty ctx fmt false ty; + (* Close "TYPE" box (depth=3) *) + F.pp_close_box fmt (); + + if not is_opaque then ( + (* Print " =" *) + F.pp_print_space fmt (); + F.pp_print_string fmt "="; + ); + (* Close ": TYPE =" box (depth=2) *) + F.pp_close_box fmt (); + (* Close "QUALIF NAME : TYPE =" box (depth=1) *) + F.pp_close_box fmt (); + + if not is_opaque then ( + F.pp_print_space fmt (); + (* Open "BODY" box (depth=1) *) + F.pp_open_hvbox fmt 0; + (* Print "BODY" *) + (Option.get extract_body) fmt; + (* Close "BODY" box (depth=1) *) + F.pp_close_box fmt () + ); + (* Close the definition box (depth=0) *) + F.pp_close_box fmt () + +(** Extract a global declaration. + This has similarity with the function extraction above (without parameters). + However, generate its body separately from its declaration to extract the result value. + + For example, + `let x = 3` + + will be translated to + `let x_body : result int = Return 3` + `let x_c : int = eval_global x_body` + *) +let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) + (qualif : fun_decl_qualif) (def : fun_decl) + : unit = + (* Sanity checks for globals *) + assert (def.is_global); + assert (Option.is_none def.back_id); + assert (List.length def.signature.inputs = 0); + assert (List.length def.signature.doutputs = 1); + assert (List.length def.signature.type_params = 0); + assert (not def.signature.info.effect_info.can_fail); + + (* Add a break then the corresponding Rust definition *) + F.pp_print_break fmt 0 0; + F.pp_print_string fmt ("(** [" ^ Print.fun_name_to_string def.basename ^ "] *)"); + F.pp_print_space fmt (); + + let def_name = ctx_get_local_function def.def_id def.back_id ctx in + match def.body with + | None -> + extract_global_definition ctx fmt qualif def_name def.signature.output None + | Some body -> + let body_name = global_decl_to_body_name def_name in + let body_ty = mk_result_ty def.signature.output in + extract_global_definition ctx fmt qualif body_name body_ty (Some (fun fmt -> + extract_texpression ctx fmt false body.body + )); + F.pp_print_break fmt 0 0; + extract_global_definition ctx fmt qualif def_name def.signature.output (Some (fun fmt -> + F.pp_print_string fmt ("eval_global " ^ body_name) + )); + F.pp_print_break fmt 0 0 + (** Extract a unit test, if the function is a unit function (takes no parameters, returns unit). diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index dc205eb9..ca20352f 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -1,6 +1,6 @@ (** Compute various information, including: - can a function fail (by having `Fail` in its body, or transitively - calling a function which can fail) + calling a function which can fail), false for globals - can a function diverge (bu being recursive, containing a loop or transitively calling a function which can diverge) - does a function perform stateful operations (i.e., do we need a state @@ -49,47 +49,56 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) let stateful = ref false in let divergent = ref false in - let obj = - object - inherit [_] iter_statement as super - - method! visit_Assert env a = - can_fail := true; - super#visit_Assert env a - - method! visit_Call env call = - (match call.func with - | Regular id -> - if FunDeclId.Set.mem id fun_ids then divergent := true - else - let info = FunDeclId.Map.find id !infos in - can_fail := !can_fail || info.can_fail; - stateful := !stateful || info.stateful; - divergent := !divergent || info.divergent - | Assumed id -> - (* None of the assumed functions is stateful for now *) - can_fail := !can_fail || Assumed.assumed_can_fail id); - super#visit_Call env call - - method! visit_Panic env = - can_fail := true; - super#visit_Panic env - - method! visit_Loop env loop = - divergent := true; - super#visit_Loop env loop - end - in - let visit_fun (f : fun_decl) : unit = + print_endline ("@ fun: " ^ Print.fun_name_to_string f.name); + let obj = + object (self) + inherit [_] iter_statement as super + + method may_fail b = + if f.is_global then () else + can_fail := !can_fail || b + + method! visit_Assert env a = + self#may_fail true; + super#visit_Assert env a + + method! visit_Call env call = + print_string "@ dep: "; + pp_fun_id Format.std_formatter call.func; + print_newline (); + + (match call.func with + | Regular id -> + if FunDeclId.Set.mem id fun_ids then divergent := true + else + let info = FunDeclId.Map.find id !infos in + self#may_fail info.can_fail; + stateful := !stateful || info.stateful; + divergent := !divergent || info.divergent + | Assumed id -> + (* None of the assumed functions is stateful for now *) + can_fail := !can_fail || Assumed.assumed_can_fail id); + super#visit_Call env call + + method! visit_Panic env = + self#may_fail true; + super#visit_Panic env + + method! visit_Loop env loop = + divergent := true; + super#visit_Loop env loop + end + in match f.body with | None -> (* Opaque function *) - can_fail := true; + obj#may_fail true; stateful := use_state | Some body -> obj#visit_statement () body.body in List.iter visit_fun d; + print_endline ("@ can_fail: " ^ Bool.to_string !can_fail); { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } in diff --git a/src/Modules.ml b/src/Modules.ml index b0e8878d..149de020 100644 --- a/src/Modules.ml +++ b/src/Modules.ml @@ -7,7 +7,8 @@ type 'id g_declaration_group = NonRec of 'id | Rec of 'id list type type_declaration_group = TypeDeclId.id g_declaration_group [@@deriving show] -type fun_declaration_group = FunDeclId.id g_declaration_group [@@deriving show] +type fun_declaration_group = FunDeclId.id g_declaration_group +[@@deriving show] (** Module declaration *) type declaration_group = diff --git a/src/PrintPure.ml b/src/PrintPure.ml index ea9bf2ab..c13f967f 100644 --- a/src/PrintPure.ml +++ b/src/PrintPure.ml @@ -44,6 +44,7 @@ type ast_formatter = { TypeDeclId.id -> VariantId.id option -> FieldId.id -> string option; adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; fun_decl_id_to_string : A.FunDeclId.id -> string; + global_decl_id_to_string : A.GlobalDeclId.id -> string; } let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = @@ -85,7 +86,9 @@ let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) while we only need those definitions to lookup proper names for the def ids. *) let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) - (fun_decls : A.fun_decl A.FunDeclId.Map.t) (type_params : type_var list) : + (fun_decls : A.fun_decl A.FunDeclId.Map.t) + (gid_conv : A.global_id_converter) + (type_params : type_var list) : ast_formatter = let type_var_id_to_string vid = let var = T.TypeVarId.nth type_params vid in @@ -112,6 +115,9 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) let def = A.FunDeclId.Map.find def_id fun_decls in fun_name_to_string def.name in + let global_decl_id_to_string def_id = + fun_decl_id_to_string (A.global_to_fun_id gid_conv def_id) + in { type_var_id_to_string; type_decl_id_to_string; @@ -120,6 +126,7 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) adt_field_names; adt_field_to_string; fun_decl_id_to_string; + global_decl_id_to_string; } let type_id_to_string (fmt : type_formatter) (id : type_id) : string = @@ -480,6 +487,7 @@ and app_to_string (fmt : ast_formatter) (inside : bool) (indent : string) let qualif_s = match qualif.id with | Func fun_id -> fun_id_to_string fmt fun_id + | Global global_id -> fmt.global_decl_id_to_string global_id | AdtCons adt_cons_id -> let variant_s = adt_variant_to_string diff --git a/src/Pure.ml b/src/Pure.ml index 42f56fed..b3be2040 100644 --- a/src/Pure.ml +++ b/src/Pure.ml @@ -302,9 +302,9 @@ type projection = { adt_id : type_id; field_id : FieldId.id } [@@deriving show] type qualif_id = | Func of fun_id + | Global of A.GlobalDeclId.id | AdtCons of adt_cons_id (** A function or ADT constructor identifier *) | Proj of projection (** Field projector *) - (* TODO | Global of GlobalDeclId.id*) [@@deriving show] type qualif = { id : qualif_id; type_args : ty list } [@@deriving show] @@ -575,5 +575,6 @@ type fun_decl = { (to identify the forward/backward functions) later. *) signature : fun_sig; + is_global : bool; body : fun_body option; } diff --git a/src/PureMicroPasses.ml b/src/PureMicroPasses.ml index 826283ae..7927a068 100644 --- a/src/PureMicroPasses.ml +++ b/src/PureMicroPasses.ml @@ -611,7 +611,10 @@ let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) | Func (Unop _ | Binop _) -> true (* primitive function call *) | Func (Regular _) -> - false (* non-primitive function call *)) + false (* non-primitive function call *) + | Global _ -> + true (* Global constant or static *) + ) | _ -> filter else false in diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml index 195eb879..e58fec2a 100644 --- a/src/PureToExtract.ml +++ b/src/PureToExtract.ml @@ -74,6 +74,7 @@ type formatter = { fun_name : A.fun_id -> fun_name -> + bool -> int -> region_group_info option -> bool * int -> @@ -440,11 +441,13 @@ let ctx_get (id : id) (ctx : extraction_ctx) : string = log#serror ("Could not find: " ^ id_to_string id ctx); raise Not_found -let ctx_get_function (id : A.fun_id) (rg : RegionGroupId.id option) +let ctx_get_function (id : A.fun_id) + (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = ctx_get (FunId (id, rg)) ctx -let ctx_get_local_function (id : A.FunDeclId.id) (rg : RegionGroupId.id option) +let ctx_get_local_function (id : A.FunDeclId.id) + (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = ctx_get_function (A.Regular id) rg ctx @@ -596,7 +599,7 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) in let def_id = A.Regular def_id in let name = - ctx.fmt.fun_name def_id def.basename num_rgs rg_info (keep_fwd, num_backs) + ctx.fmt.fun_name def_id def.basename def.is_global num_rgs rg_info (keep_fwd, num_backs) in (* Add the function name *) let ctx = ctx_add (FunId (def_id, def.back_id)) name ctx in @@ -666,8 +669,12 @@ let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = information. TODO: move all those helpers. *) -let default_fun_suffix (num_region_groups : int) (rg : region_group_info option) - ((keep_fwd, num_backs) : bool * int) : string = +let default_fun_suffix + (is_global : bool) + (num_region_groups : int) + (rg : region_group_info option) + ((keep_fwd, num_backs) : bool * int) + : string = (* There are several cases: - [rg] is `Some`: this is a forward function: - we add "_fwd" @@ -683,6 +690,7 @@ let default_fun_suffix (num_region_groups : int) (rg : region_group_info option) we could not add the "_fwd" suffix) to prevent name clashes between definitions (in particular between type and function definitions). *) + if is_global then "_c" else match rg with | None -> "_fwd" | Some rg -> diff --git a/src/PureTypeCheck.ml b/src/PureTypeCheck.ml index 8848ff20..90b9ab09 100644 --- a/src/PureTypeCheck.ml +++ b/src/PureTypeCheck.ml @@ -111,7 +111,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = check_texpression ctx body | Qualif qualif -> ( match qualif.id with - | Func _ -> () (* TODO *) + | Func _ | Global _ -> () (* TODO *) | Proj { adt_id = proj_adt_id; field_id } -> (* Note we can only project fields of structures (not enumerations) *) (* Deconstruct the projector type *) diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml index 927684bc..84536005 100644 --- a/src/SymbolicToPure.ml +++ b/src/SymbolicToPure.ml @@ -144,7 +144,8 @@ let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = let type_params = ctx.fun_decl.signature.type_params in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in - PrintPure.mk_ast_formatter type_decls fun_decls type_params + let gid_conv = ctx.fun_context.gid_conv in + PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params let ty_to_string (ctx : bs_ctx) (ty : ty) : string = let fmt = bs_ctx_to_pp_ast_formatter ctx in @@ -165,14 +166,16 @@ let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = let type_params = sg.type_params in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls type_params in + let gid_conv = ctx.fun_context.gid_conv in + let fmt = PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = let type_params = def.signature.type_params in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls type_params in + let gid_conv = ctx.fun_context.gid_conv in + let fmt = PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params in PrintPure.fun_decl_to_string fmt def (* TODO: move *) @@ -482,7 +485,7 @@ let get_fun_effect_info (fun_infos : FA.fun_info A.FunDeclId.Map.t) let info = A.FunDeclId.Map.find fid fun_infos in let input_state = info.stateful in let output_state = input_state && gid = None in - { can_fail = true; input_state; output_state } + { can_fail = info.can_fail; input_state; output_state } | A.Assumed aid -> { can_fail = Assumed.assumed_can_fail aid; @@ -1663,6 +1666,7 @@ let translate_fun_decl (config : config) (ctx : bs_ctx) (* Lookup the signature *) let signature = bs_ctx_lookup_local_function_sig def_id bid ctx in (* Translate the body, if there is *) + let is_global = def.A.is_global in let body = match body with | None -> None @@ -1723,7 +1727,7 @@ let translate_fun_decl (config : config) (ctx : bs_ctx) Some { inputs; inputs_lvs; body } in (* Assemble the declaration *) - let def = { def_id; back_id = bid; basename; signature; body } in + let def = { def_id; back_id = bid; basename; signature; is_global; body } in (* Debugging *) log#ldebug (lazy diff --git a/src/Translate.ml b/src/Translate.ml index d4d79355..9412b8b8 100644 --- a/src/Translate.ml +++ b/src/Translate.ml @@ -495,9 +495,10 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) if ((not is_opaque) && config.extract_transparent) || (is_opaque && config.extract_opaque) - then - ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif - has_decr_clause def) + then if def.is_global + then ExtractToFStar.extract_global_decl ctx.extract_ctx fmt qualif def + else ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif has_decr_clause def + ) fls); (* Insert unit tests if necessary *) if config.test_unit_functions then diff --git a/src/TranslateCore.ml b/src/TranslateCore.ml index ccaa9e22..047219ad 100644 --- a/src/TranslateCore.ml +++ b/src/TranslateCore.ml @@ -40,14 +40,16 @@ let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = let type_params = sg.type_params in let type_decls = ctx.type_context.type_decls in let fun_decls = ctx.fun_context.fun_decls in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls type_params in + let gid_conv = ctx.fun_context.gid_conv in + let fmt = PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = let type_params = def.signature.type_params in let type_decls = ctx.type_context.type_decls in let fun_decls = ctx.fun_context.fun_decls in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls type_params in + let gid_conv = ctx.fun_context.gid_conv in + let fmt = PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params in PrintPure.fun_decl_to_string fmt def let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = -- cgit v1.2.3 From eebedf86db68c240fe16cfd74af2cc462b0d9cf9 Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Tue, 5 Jul 2022 12:16:36 +0200 Subject: Remove last prints, adapt JSON --- src/FunsAnalysis.ml | 3 --- src/LlbcOfJson.ml | 6 +++--- 2 files changed, 3 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index ee4f71c1..5a623450 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -74,9 +74,6 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) can_fail := EU.binop_can_fail bop || !can_fail method! visit_Call env call = - pp_fun_id Format.std_formatter call.func; - print_newline (); - (match call.func with | Regular id -> if FunDeclId.Set.mem id fun_ids then divergent := true diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml index 3ff45077..c157b667 100644 --- a/src/LlbcOfJson.ml +++ b/src/LlbcOfJson.ml @@ -644,13 +644,13 @@ let global_decl_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_ [ ("def_id", def_id); ("name", name); - ("type_", type_); + ("ty", ty); ("body", body); ] -> let* global_id = A.GlobalDeclId.id_of_json def_id in let def_id = A.global_to_fun_id gid_conv global_id in let* name = fun_name_of_json name in - let* type_ = ety_of_json type_ in + let* ty = ety_of_json ty in let* body = option_of_json (fun js -> fun_body_of_json js gid_conv) body in let signature : A.fun_sig = { region_params = []; @@ -658,7 +658,7 @@ let global_decl_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_ regions_hierarchy = []; type_params = []; inputs = []; - output = TU.ety_no_regions_to_sty type_; + output = TU.ety_no_regions_to_sty ty; } in Ok { A.def_id; name; signature; body; is_global = true; } | _ -> Error "") -- cgit v1.2.3 From 8f14d69ae6683e58e1387ffe38ca3612e0530465 Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Wed, 13 Jul 2022 15:56:24 +0200 Subject: Apply small changes from the PR --- src/Expressions.ml | 1 - src/ExtractToFStar.ml | 8 ++++---- src/FunsAnalysis.ml | 3 +++ src/InterpreterExpressions.ml | 9 +++++---- 4 files changed, 12 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/Expressions.ml b/src/Expressions.ml index 6645a77f..bf06dd1e 100644 --- a/src/Expressions.ml +++ b/src/Expressions.ml @@ -72,7 +72,6 @@ let all_binops = Shr; ] -(* TODO: symplify the operand constant values *) type operand = | Copy of place | Move of place diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 20b06bfa..5b39b0b7 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -26,7 +26,7 @@ type type_decl_qualif = *) type fun_decl_qualif = Let | LetRec | And | Val | AssumeVal -let fun_decl_qualif_name (qualif : fun_decl_qualif) : string = +let fun_decl_qualif_keyword (qualif : fun_decl_qualif) : string = match qualif with | Let -> "let" | LetRec -> "let rec" @@ -1368,7 +1368,7 @@ let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_open_hovbox fmt ctx.indent_incr; (* > "let FUN_NAME" *) let is_opaque = Option.is_none def.body in - let qualif = fun_decl_qualif_name qualif in + let qualif = fun_decl_qualif_keyword qualif in F.pp_print_string fmt (qualif ^ " " ^ def_name); F.pp_print_space fmt (); (* Open a box for "(PARAMS) : EFFECT =" *) @@ -1498,7 +1498,7 @@ let extract_global_definition (ctx : extraction_ctx) (fmt : F.formatter) (* Open "QUALIF NAME : TYPE =" box (depth=1) *) F.pp_open_hovbox fmt ctx.indent_incr; (* Print "QUALIF NAME " *) - F.pp_print_string fmt (fun_decl_qualif_name qualif ^ " " ^ name); + F.pp_print_string fmt (fun_decl_qualif_keyword qualif ^ " " ^ name); F.pp_print_space fmt (); (* Open ": TYPE =" box (depth=2) *) @@ -1558,7 +1558,7 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) assert (List.length def.signature.type_params = 0); assert (not def.signature.info.effect_info.can_fail); - (* Add a break then the corresponding Rust definition *) + (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; F.pp_print_string fmt ("(** [" ^ Print.fun_name_to_string def.basename ^ "] *)"); F.pp_print_space fmt (); diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index 5a623450..b1b8ccc2 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -58,6 +58,8 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) method may_fail b = (* The fail flag is disabled for globals : the global body is * normalised into its declaration, which is always successful. + * (we check that it is successful in the extracted code: if it is + * not, it leads to a type-checking error in the generated files) *) if f.is_global then () else can_fail := !can_fail || b @@ -96,6 +98,7 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) super#visit_Loop env loop end in + assert (not f.is_global || not use_state); (match f.body with | None -> (* Opaque function *) diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index 04ad1b3c..4598895e 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -110,13 +110,13 @@ let access_rplace_reorganize (config : C.config) (expand_prim_copy : bool) ctx (** Convert an operand constant operand value to a typed value *) -let typecheck_constant_value (ty : T.ety) +let constant_to_typed_value (ty : T.ety) (cv : V.constant_value) : V.typed_value = (* Check the type while converting - we actually need some information * contained in the type *) log#ldebug (lazy - ("typecheck_constant_value:" ^ "\n- cv: " + ("constant_to_typed_value:" ^ "\n- cv: " ^ PV.constant_value_to_string cv)); match (ty, cv) with (* Scalar, boolean... *) @@ -175,7 +175,8 @@ let prepare_eval_operand_reorganize (config : C.config) (op : E.operand) : fun cf ctx -> match op with | Expressions.Constant (ty, cv) -> - typecheck_constant_value ty cv |> ignore; + (* No need to reorganize the context *) + constant_to_typed_value ty cv |> ignore; cf ctx | Expressions.Copy p -> (* Access the value *) @@ -203,7 +204,7 @@ let eval_operand_no_reorganize (config : C.config) (op : E.operand) ^ "\n- ctx:\n" ^ eval_ctx_to_string ctx ^ "\n")); (* Evaluate *) match op with - | Expressions.Constant (ty, cv) -> cf (typecheck_constant_value ty cv) ctx + | Expressions.Constant (ty, cv) -> cf (constant_to_typed_value ty cv) ctx | Expressions.Copy p -> (* Access the value *) let access = Read in -- cgit v1.2.3 From f9b324be57708e9496ca6e9ac0b7e68ffd9e7108 Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Mon, 18 Jul 2022 16:27:00 +0200 Subject: Address much stuff of the PR, throw exceptions at remaining places --- src/Contexts.ml | 11 +++++-- src/ExtractToFStar.ml | 11 +++++-- src/FunsAnalysis.ml | 6 ++-- src/Interpreter.ml | 44 +++++++++++++++----------- src/InterpreterStatements.ml | 3 +- src/LlbcAst.ml | 21 ++++++------- src/LlbcOfJson.ml | 73 +++++++++++++++++++++++++++----------------- src/Modules.ml | 11 +++++-- src/Names.ml | 2 ++ src/Print.ml | 23 ++++++++------ src/PrintPure.ml | 9 ++++-- src/Pure.ml | 2 +- src/PureToExtract.ml | 7 +++-- src/SymbolicToPure.ml | 23 ++++++++------ src/Translate.ml | 21 +++++++------ src/TranslateCore.ml | 17 +++++++---- 16 files changed, 172 insertions(+), 112 deletions(-) (limited to 'src') diff --git a/src/Contexts.ml b/src/Contexts.ml index 1fbc916b..4f1e1506 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -219,13 +219,18 @@ type type_context = { type fun_context = { fun_decls : fun_decl FunDeclId.Map.t; - gid_conv : global_id_converter; +} +[@@deriving show] + +type global_context = { + global_decls : global_decl GlobalDeclId.Map.t; } [@@deriving show] type eval_ctx = { type_context : type_context; fun_context : fun_context; + global_context : global_context; type_vars : type_var list; env : env; ended_regions : RegionId.Set.t; @@ -260,8 +265,8 @@ let ctx_lookup_fun_decl (ctx : eval_ctx) (fid : FunDeclId.id) : fun_decl = FunDeclId.Map.find fid ctx.fun_context.fun_decls (** TODO: make this more efficient with maps *) -let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : fun_decl = - ctx_lookup_fun_decl ctx (global_to_fun_id ctx.fun_context.gid_conv gid) +let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : global_decl = + GlobalDeclId.Map.find gid ctx.global_context.global_decls (** Retrieve a variable's value in an environment *) let env_lookup_var_value (env : env) (vid : VarId.id) : typed_value = diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 5b39b0b7..2c53e45b 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -907,9 +907,12 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) | Func fun_id -> extract_function_call ctx fmt inside fun_id qualif.type_args args | Global global_id -> + failwith "TODO ExtractToFStar.ml:911" + (* Previous code: let fid = A.global_to_fun_id ctx.trans_ctx.fun_context.gid_conv global_id in let fun_id = Regular (A.Regular fid, None) in extract_function_call ctx fmt inside fun_id qualif.type_args args + *) | AdtCons adt_cons_id -> extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args args | Proj proj -> @@ -1485,7 +1488,7 @@ let global_decl_to_body_name (decl : string) : string = assert (String.sub decl base_len 2 = "_c"); (String.sub decl 0 base_len) ^ "_body" -(** Print a definition of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) +(** Extract a global definition of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) let extract_global_definition (ctx : extraction_ctx) (fmt : F.formatter) (qualif : fun_decl_qualif) (name : string) (ty : ty) (extract_body : (F.formatter -> unit) Option.t) @@ -1550,8 +1553,11 @@ let extract_global_definition (ctx : extraction_ctx) (fmt : F.formatter) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (qualif : fun_decl_qualif) (def : fun_decl) : unit = + (* TODO Lookup LLBC decl *) (* Sanity checks for globals *) - assert (def.is_global); + assert (def.is_global_body); + failwith "TODO ExtractToFStar.ml:1559" + (* Previous code: assert (Option.is_none def.back_id); assert (List.length def.signature.inputs = 0); assert (List.length def.signature.doutputs = 1); @@ -1578,6 +1584,7 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt ("eval_global " ^ body_name) )); F.pp_print_break fmt 0 0 + *) (** Extract a unit test, if the function is a unit function (takes no parameters, returns unit). diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index b1b8ccc2..034575c0 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -61,7 +61,7 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) * (we check that it is successful in the extracted code: if it is * not, it leads to a type-checking error in the generated files) *) - if f.is_global then () else + if f.is_global_body then () else can_fail := !can_fail || b method! visit_Assert env a = @@ -98,7 +98,7 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) super#visit_Loop env loop end in - assert (not f.is_global || not use_state); + assert (not f.is_global_body || not use_state); (match f.body with | None -> (* Opaque function *) @@ -108,7 +108,7 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) (* We ignore on purpose functions that cannot fail: the result of the analysis * is not used yet to adjust the translation so that the functions which * syntactically can't fail don't use an error monad. *) - can_fail := not f.is_global + can_fail := not f.is_global_body in List.iter visit_fun d; { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } diff --git a/src/Interpreter.ml b/src/Interpreter.ml index f4f01ff8..3610d486 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -14,9 +14,9 @@ module SA = SymbolicAst let log = L.interpreter_log let compute_type_fun_contexts (m : M.llbc_module) : - C.type_context * C.fun_context = + C.type_context * C.fun_context * C.global_context = let type_decls_list, _ = M.split_declarations m.declarations in - let type_decls, fun_decls = M.compute_defs_maps m in + let type_decls, fun_decls, global_decls = M.compute_defs_maps m in let type_decls_groups, _funs_defs_groups = M.split_declarations_to_group_maps m.declarations in @@ -24,15 +24,20 @@ let compute_type_fun_contexts (m : M.llbc_module) : TypesAnalysis.analyze_type_declarations type_decls type_decls_list in let type_context = { C.type_decls_groups; type_decls; type_infos } in - let fun_context = { C.fun_decls; gid_conv = m.gid_conv } in - (type_context, fun_context) - -let initialize_eval_context (type_context : C.type_context) - (fun_context : C.fun_context) (type_vars : T.type_var list) : C.eval_ctx = + let fun_context = { C.fun_decls } in + let global_context = { C.global_decls } in + (type_context, fun_context, global_context) + +let initialize_eval_context + (type_context : C.type_context) + (fun_context : C.fun_context) + (global_context : C.global_context) + (type_vars : T.type_var list) : C.eval_ctx = C.reset_global_counters (); { C.type_context; C.fun_context; + C.global_context; C.type_vars; C.env = [ C.Frame ]; C.ended_regions = T.RegionId.Set.empty; @@ -51,8 +56,11 @@ let initialize_eval_context (type_context : C.type_context) - the list of symbolic values introduced for the input values - the instantiated function signature *) -let initialize_symbolic_context_for_fun (type_context : C.type_context) - (fun_context : C.fun_context) (fdef : A.fun_decl) : +let initialize_symbolic_context_for_fun + (type_context : C.type_context) + (fun_context : C.fun_context) + (global_context : C.global_context) + (fdef : A.fun_decl) : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = (* The abstractions are not initialized the same way as for function * calls: they contain *loan* projectors, because they "provide" us @@ -67,7 +75,7 @@ let initialize_symbolic_context_for_fun (type_context : C.type_context) * *) let sg = fdef.signature in (* Create the context *) - let ctx = initialize_eval_context type_context fun_context sg.type_params in + let ctx = initialize_eval_context type_context fun_context global_context sg.type_params in (* Instantiate the signature *) let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in let inst_sg = instantiate_fun_sig type_params sg in @@ -204,7 +212,7 @@ let evaluate_function_symbolic_synthesize_backward_from_return - the symbolic AST generated by the symbolic execution *) let evaluate_function_symbolic (config : C.partial_config) (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) + (type_context : C.type_context) (fun_context : C.fun_context) (global_context : C.global_context) (fdef : A.fun_decl) (back_id : T.RegionGroupId.id option) : V.symbolic_value list * SA.expression option = (* Debug *) @@ -218,7 +226,7 @@ let evaluate_function_symbolic (config : C.partial_config) (synthesize : bool) (* Create the evaluation context *) let ctx, input_svs, inst_sg = - initialize_symbolic_context_for_fun type_context fun_context fdef + initialize_symbolic_context_for_fun type_context fun_context global_context fdef in (* Create the continuation to finish the evaluation *) @@ -285,8 +293,8 @@ module Test = struct assert (body.A.arg_count = 0); (* Create the evaluation context *) - let type_context, fun_context = compute_type_fun_contexts m in - let ctx = initialize_eval_context type_context fun_context [] in + let type_context, fun_context, global_context = compute_type_fun_contexts m in + let ctx = initialize_eval_context type_context fun_context global_context [] in (* Insert the (uninitialized) local variables *) let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in @@ -330,7 +338,7 @@ module Test = struct (** Execute the symbolic interpreter on a function. *) let test_function_symbolic (config : C.partial_config) (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) + (type_context : C.type_context) (fun_context : C.fun_context) (global_context : C.global_context) (fdef : A.fun_decl) : unit = (* Debug *) log#ldebug @@ -338,7 +346,7 @@ module Test = struct (* Evaluate *) let evaluate = - evaluate_function_symbolic config synthesize type_context fun_context fdef + evaluate_function_symbolic config synthesize type_context fun_context global_context fdef in (* Execute the forward function *) let _ = evaluate None in @@ -368,12 +376,12 @@ module Test = struct in (* Filter the opaque functions *) let no_loop_funs = List.filter fun_decl_is_transparent no_loop_funs in - let type_context, fun_context = compute_type_fun_contexts m in + let type_context, fun_context, global_context = compute_type_fun_contexts m in let test_fun (def : A.fun_decl) : unit = (* Execute the function - note that as the symbolic interpreter explores * all the path, some executions are expected to "panic": we thus don't * check the return value *) - test_function_symbolic config synthesize type_context fun_context def + test_function_symbolic config synthesize type_context fun_context global_context def in List.iter test_fun no_loop_funs end diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 8f981174..6a0b81f3 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -832,8 +832,9 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = (* Compose and apply *) comp cf_eval_rvalue cf_assign cf ctx | A.AssignGlobal { dst; global } -> + (* What codegen do we want ? *) let call : A.call = { - func = A.Regular (A.global_to_fun_id ctx.fun_context.gid_conv global); + func = A.Regular (failwith "TODO InterpretStatements.ml:837"); region_args = []; type_args = []; args = []; diff --git a/src/LlbcAst.ml b/src/LlbcAst.ml index 16733e20..aa9b0665 100644 --- a/src/LlbcAst.ml +++ b/src/LlbcAst.ml @@ -7,17 +7,6 @@ open Identifiers module FunDeclId = IdGen () module GlobalDeclId = IdGen () -(* Strict type for the number of function declarations (see [global_to_fun_id] below) *) -type global_id_converter = { fun_count : int } -[@@deriving show] - -(** Converts a global id to its corresponding function id. - To do so, it adds the global id to the number of function declarations : - We have the bijection `global_id <=> fun_id + fun_id_count`. -*) -let global_to_fun_id (conv : global_id_converter) (gid : GlobalDeclId.id) : FunDeclId.id = - FunDeclId.of_int ((GlobalDeclId.to_int gid) + conv.fun_count) - type var = { index : VarId.id; (** Unique variable identifier *) name : string option; @@ -201,6 +190,14 @@ type fun_decl = { name : fun_name; signature : fun_sig; body : fun_body option; - is_global : bool; + is_global_body : bool; +} +[@@deriving show] + +type global_decl = { + def_id : GlobalDeclId.id; + body_id: FunDeclId.id; + name : global_name; + ty: ety; } [@@deriving show] diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml index c157b667..f51c15be 100644 --- a/src/LlbcOfJson.ml +++ b/src/LlbcOfJson.ml @@ -540,7 +540,7 @@ let call_of_json (js : json) : (A.call, string) result = Ok { A.func; region_args; type_args; args; dest } | _ -> Error "") -let rec statement_of_json (js : json) (gid_conv : A.global_id_converter) : (A.statement, string) result = +let rec statement_of_json (js : json) : (A.statement, string) result = combine_error_msgs js "statement_of_json" (match js with | `Assoc [ ("Assign", `List [ place; rvalue ]) ] -> @@ -577,48 +577,49 @@ let rec statement_of_json (js : json) (gid_conv : A.global_id_converter) : (A.st Ok (A.Continue i) | `String "Nop" -> Ok A.Nop | `Assoc [ ("Sequence", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json st1 gid_conv in - let* st2 = statement_of_json st2 gid_conv in + let* st1 = statement_of_json st1 in + let* st2 = statement_of_json st2 in Ok (A.Sequence (st1, st2)) | `Assoc [ ("Switch", `List [ op; tgt ]) ] -> let* op = operand_of_json op in - let* tgt = switch_targets_of_json tgt gid_conv in + let* tgt = switch_targets_of_json tgt in Ok (A.Switch (op, tgt)) | `Assoc [ ("Loop", st) ] -> - let* st = statement_of_json st gid_conv in + let* st = statement_of_json st in Ok (A.Loop st) | _ -> Error "") -and switch_targets_of_json (js : json) (gid_conv : A.global_id_converter) : (A.switch_targets, string) result = +and switch_targets_of_json (js : json) : (A.switch_targets, string) result = combine_error_msgs js "switch_targets_of_json" (match js with | `Assoc [ ("If", `List [ st1; st2 ]) ] -> - let* st1 = statement_of_json st1 gid_conv in - let* st2 = statement_of_json st2 gid_conv in + let* st1 = statement_of_json st1 in + let* st2 = statement_of_json st2 in Ok (A.If (st1, st2)) | `Assoc [ ("SwitchInt", `List [ int_ty; tgts; otherwise ]) ] -> let* int_ty = integer_type_of_json int_ty in let* tgts = - list_of_json (pair_of_json + list_of_json ( + pair_of_json (list_of_json scalar_value_of_json) - (fun js -> statement_of_json js gid_conv)) + statement_of_json) tgts in - let* otherwise = statement_of_json otherwise gid_conv in + let* otherwise = statement_of_json otherwise in Ok (A.SwitchInt (int_ty, tgts, otherwise)) | _ -> Error "") -let fun_body_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_body, string) result = +let fun_body_of_json (js : json) : (A.fun_body, string) result = combine_error_msgs js "fun_body_of_json" (match js with | `Assoc [ ("arg_count", arg_count); ("locals", locals); ("body", body) ] -> let* arg_count = int_of_json arg_count in let* locals = list_of_json var_of_json locals in - let* body = statement_of_json body gid_conv in + let* body = statement_of_json body in Ok { A.arg_count; locals; body } | _ -> Error "") -let fun_decl_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_decl, string) result = +let fun_decl_of_json (js : json) : (A.fun_decl, string) result = combine_error_msgs js "fun_decl_of_json" (match js with | `Assoc @@ -631,13 +632,24 @@ let fun_decl_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_dec let* def_id = A.FunDeclId.id_of_json def_id in let* name = fun_name_of_json name in let* signature = fun_sig_of_json signature in - let* body = option_of_json (fun js -> fun_body_of_json js gid_conv) body in - Ok { A.def_id; name; signature; body; is_global = false; } + let* body = option_of_json fun_body_of_json body in + Ok { A.def_id; name; signature; body; is_global_body = false; } | _ -> Error "") +(* Strict type for the number of function declarations (see [global_to_fun_id] below) *) +type global_id_converter = { fun_count : int } +[@@deriving show] + +(** Converts a global id to its corresponding function id. + To do so, it adds the global id to the number of function declarations : + We have the bijection `global_id <=> fun_id + fun_id_count`. +*) +let global_to_fun_id (conv : global_id_converter) (gid : A.GlobalDeclId.id) : A.FunDeclId.id = + A.FunDeclId.of_int ((A.GlobalDeclId.to_int gid) + conv.fun_count) + (* Converts a global declaration to a function declaration. *) -let global_decl_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_decl, string) result = +let global_decl_of_json (js : json) (gid_conv : global_id_converter) : (A.global_decl * A.fun_decl, string) result = combine_error_msgs js "global_decl_of_json" (match js with | `Assoc @@ -648,10 +660,10 @@ let global_decl_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_ ("body", body); ] -> let* global_id = A.GlobalDeclId.id_of_json def_id in - let def_id = A.global_to_fun_id gid_conv global_id in + let fun_id = global_to_fun_id gid_conv global_id in let* name = fun_name_of_json name in let* ty = ety_of_json ty in - let* body = option_of_json (fun js -> fun_body_of_json js gid_conv) body in + let* body = option_of_json fun_body_of_json body in let signature : A.fun_sig = { region_params = []; num_early_bound_regions = 0; @@ -660,7 +672,8 @@ let global_decl_of_json (js : json) (gid_conv : A.global_id_converter) : (A.fun_ inputs = []; output = TU.ety_no_regions_to_sty ty; } in - Ok { A.def_id; name; signature; body; is_global = true; } + Ok ({ A.def_id = global_id; body_id = fun_id; name; ty; }, + { A.def_id = fun_id; name; signature; body; is_global_body = true; }) | _ -> Error "") let g_declaration_group_of_json (id_of_json : json -> ('id, string) result) @@ -685,15 +698,18 @@ let fun_declaration_group_of_json (js : json) : combine_error_msgs js "fun_declaration_group_of_json" (g_declaration_group_of_json A.FunDeclId.id_of_json js) -let global_declaration_group_of_json (js : json) (gid_conv : A.global_id_converter) : +(* TODO Should a global declaration group be converted to its function bodies ? + It does not seems very clean. +*) +let global_declaration_group_of_json (js : json) (gid_conv : global_id_converter) : (M.fun_declaration_group, string) result = combine_error_msgs js "global_declaration_group_of_json" (g_declaration_group_of_json (fun js -> let* id = A.GlobalDeclId.id_of_json js in - Ok (A.global_to_fun_id gid_conv id) + Ok (global_to_fun_id gid_conv id) ) js) -let declaration_group_of_json (js : json) (gid_conv : A.global_id_converter) : (M.declaration_group, string) result +let declaration_group_of_json (js : json) (gid_conv : global_id_converter) : (M.declaration_group, string) result = combine_error_msgs js "declaration_of_json" (match js with @@ -726,19 +742,20 @@ let llbc_module_of_json (js : json) : (M.llbc_module, string) result = ("globals", globals); ] -> let* fun_count = length_of_json_list functions in - let gid_conv = { A.fun_count = fun_count } in + let gid_conv = { fun_count } in let* name = string_of_json name in let* declarations = list_of_json (fun js -> declaration_group_of_json js gid_conv) declarations in - let* types = list_of_json type_decl_of_json types in - let* functions = list_of_json (fun js -> fun_decl_of_json js gid_conv) functions in + let* types = list_of_json type_decl_of_json types in + let* functions = list_of_json fun_decl_of_json functions in let* globals = list_of_json (fun js -> global_decl_of_json js gid_conv) globals in + let globals, global_bodies = List.split globals in Ok { M.name; declarations; types; - functions = functions @ globals; - gid_conv; + functions = functions @ global_bodies; + globals; } | _ -> Error "") diff --git a/src/Modules.ml b/src/Modules.ml index 149de020..2f640636 100644 --- a/src/Modules.ml +++ b/src/Modules.ml @@ -21,12 +21,12 @@ type llbc_module = { declarations : declaration_group list; types : type_decl list; functions : fun_decl list; - gid_conv : global_id_converter; + globals : global_decl list; } (** LLBC module - TODO: rename to crate *) let compute_defs_maps (m : llbc_module) : - type_decl TypeDeclId.Map.t * fun_decl FunDeclId.Map.t = + type_decl TypeDeclId.Map.t * fun_decl FunDeclId.Map.t * global_decl GlobalDeclId.Map.t = let types_map = List.fold_left (fun m (def : type_decl) -> TypeDeclId.Map.add def.def_id def m) @@ -37,7 +37,12 @@ let compute_defs_maps (m : llbc_module) : (fun m (def : fun_decl) -> FunDeclId.Map.add def.def_id def m) FunDeclId.Map.empty m.functions in - (types_map, funs_map) + let globals_map = + List.fold_left + (fun m (def : global_decl) -> GlobalDeclId.Map.add def.def_id def m) + GlobalDeclId.Map.empty m.globals + in + (types_map, funs_map, globals_map) (** Split a module's declarations between types and functions *) let split_declarations (decls : declaration_group list) : diff --git a/src/Names.ml b/src/Names.ml index 1308eccc..0db5291a 100644 --- a/src/Names.ml +++ b/src/Names.ml @@ -54,6 +54,8 @@ type type_name = name [@@deriving show, ord] type fun_name = name [@@deriving show, ord] +type global_name = name [@@deriving show, ord] + (** Filter the disambiguators equal to 0 in a name *) let filter_disambiguators_zero (n : name) : name = let pred (pe : path_elem) : bool = diff --git a/src/Print.ml b/src/Print.ml index 337116ec..6b11a3ff 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -13,6 +13,7 @@ let option_to_string (to_string : 'a -> string) (x : 'a option) : string = let name_to_string (name : name) : string = Names.name_to_string name let fun_name_to_string (name : fun_name) : string = name_to_string name +let global_name_to_string (name : global_name) : string = name_to_string name (** Pretty-printing for types *) module Types = struct @@ -744,7 +745,8 @@ module LlbcAst = struct fun_name_to_string def.name in let global_decl_id_to_string def_id = - fun_decl_id_to_string (A.global_to_fun_id ctx.fun_context.gid_conv def_id) + let def = C.ctx_lookup_global_decl ctx def_id in + global_name_to_string def.name in { rvar_to_string = ctx_fmt.PV.rvar_to_string; @@ -762,7 +764,7 @@ module LlbcAst = struct let fun_decl_to_ast_formatter (type_decls : T.type_decl T.TypeDeclId.Map.t) (fun_decls : A.fun_decl A.FunDeclId.Map.t) - (global_to_fun_id : A.GlobalDeclId.id -> A.FunDeclId.id) + (global_decls : A.global_decl A.GlobalDeclId.Map.t) (fdef : A.fun_decl) : ast_formatter = let rvar_to_string r = @@ -793,7 +795,8 @@ module LlbcAst = struct fun_name_to_string def.name in let global_decl_id_to_string def_id = - fun_decl_id_to_string (global_to_fun_id def_id) + let def = A.GlobalDeclId.Map.find def_id global_decls in + global_name_to_string def.name in { rvar_to_string; @@ -1132,7 +1135,7 @@ module Module = struct let def_ctx_to_ast_formatter (type_context : T.type_decl T.TypeDeclId.Map.t) (fun_context : A.fun_decl A.FunDeclId.Map.t) - (global_to_fun_id : A.GlobalDeclId.id -> A.FunDeclId.id) + (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : PA.ast_formatter = let rvar_to_string vid = @@ -1156,7 +1159,8 @@ module Module = struct fun_name_to_string def.name in let global_decl_id_to_string def_id = - fun_decl_id_to_string (global_to_fun_id def_id) + let def = A.GlobalDeclId.Map.find def_id global_context in + global_name_to_string def.name in let var_id_to_string vid = let var = V.VarId.nth (Option.get def.body).locals vid in @@ -1187,21 +1191,20 @@ module Module = struct let fun_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) (fun_context : A.fun_decl A.FunDeclId.Map.t) - (global_to_fun_id : A.GlobalDeclId.id -> A.FunDeclId.id) + (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : string = - let fmt = def_ctx_to_ast_formatter type_context fun_context global_to_fun_id def in + let fmt = def_ctx_to_ast_formatter type_context fun_context global_context def in PA.fun_decl_to_string fmt "" " " def let module_to_string (m : M.llbc_module) : string = - let types_defs_map, funs_defs_map = M.compute_defs_maps m in + let types_defs_map, funs_defs_map, globals_defs_map = M.compute_defs_maps m in (* The types *) let type_decls = List.map (type_decl_to_string types_defs_map) m.M.types in (* The functions *) let fun_decls = - let gid_to_fid = fun gid -> A.global_to_fun_id m.gid_conv gid in - List.map (fun_decl_to_string types_defs_map funs_defs_map gid_to_fid) m.M.functions + List.map (fun_decl_to_string types_defs_map funs_defs_map globals_defs_map) m.M.functions in (* Put everything together *) diff --git a/src/PrintPure.ml b/src/PrintPure.ml index c13f967f..597330bf 100644 --- a/src/PrintPure.ml +++ b/src/PrintPure.ml @@ -62,6 +62,7 @@ let ast_to_type_formatter (fmt : ast_formatter) : type_formatter = let name_to_string = Print.name_to_string let fun_name_to_string = Print.fun_name_to_string +let global_name_to_string = Print.global_name_to_string let option_to_string = Print.option_to_string let type_var_to_string = Print.Types.type_var_to_string let integer_type_to_string = Print.Types.integer_type_to_string @@ -85,9 +86,10 @@ let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) functions (there is a difference between the forward/backward functions...) while we only need those definitions to lookup proper names for the def ids. *) -let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) +let mk_ast_formatter + (type_decls : T.type_decl TypeDeclId.Map.t) (fun_decls : A.fun_decl A.FunDeclId.Map.t) - (gid_conv : A.global_id_converter) + (global_decls : A.global_decl A.GlobalDeclId.Map.t) (type_params : type_var list) : ast_formatter = let type_var_id_to_string vid = @@ -116,7 +118,8 @@ let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) fun_name_to_string def.name in let global_decl_id_to_string def_id = - fun_decl_id_to_string (A.global_to_fun_id gid_conv def_id) + let def = A.GlobalDeclId.Map.find def_id global_decls in + global_name_to_string def.name in { type_var_id_to_string; diff --git a/src/Pure.ml b/src/Pure.ml index b3be2040..5244b0bc 100644 --- a/src/Pure.ml +++ b/src/Pure.ml @@ -575,6 +575,6 @@ type fun_decl = { (to identify the forward/backward functions) later. *) signature : fun_sig; - is_global : bool; + is_global_body : bool; body : fun_body option; } diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml index e58fec2a..7a10bb6b 100644 --- a/src/PureToExtract.ml +++ b/src/PureToExtract.ml @@ -83,14 +83,15 @@ type formatter = { - function id: this is especially useful to identify whether the function is an assumed function or a local function - function basename + - flag indicating if the function is a global - number of region groups + - region group information in case of a backward function + (`None` if forward function) - pair: - do we generate the forward function (it may have been filtered)? - the number of extracted backward functions (not necessarily equal to the number of region groups, because we may have filtered some of them) - - region group information in case of a backward function - (`None` if forward function) TODO: use the fun id for the assumed functions. *) decreases_clause_name : A.FunDeclId.id -> fun_name -> string; @@ -599,7 +600,7 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) in let def_id = A.Regular def_id in let name = - ctx.fmt.fun_name def_id def.basename def.is_global num_rgs rg_info (keep_fwd, num_backs) + ctx.fmt.fun_name def_id def.basename def.is_global_body num_rgs rg_info (keep_fwd, num_backs) in (* Add the function name *) let ctx = ctx_add (FunId (def_id, def.back_id)) name ctx in diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml index a057b015..7d9e2906 100644 --- a/src/SymbolicToPure.ml +++ b/src/SymbolicToPure.ml @@ -70,7 +70,10 @@ type fun_context = { llbc_fun_decls : A.fun_decl A.FunDeclId.Map.t; fun_sigs : fun_sig_named_outputs RegularFunIdMap.t; (** *) fun_infos : FA.fun_info A.FunDeclId.Map.t; - gid_conv : A.global_id_converter; +} + +type global_context = { + llbc_global_decls : A.global_decl A.GlobalDeclId.Map.t; } type call_info = { @@ -96,6 +99,7 @@ type call_info = { type bs_ctx = { type_context : type_context; fun_context : fun_context; + global_context : global_context; fun_decl : A.fun_decl; bid : T.RegionGroupId.id option; (** TODO: rename *) sg : fun_sig; @@ -137,15 +141,15 @@ let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.LlbcAst.ast_formatter = Print.LlbcAst.fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls ctx.fun_context.llbc_fun_decls - (A.global_to_fun_id ctx.fun_context.gid_conv) + ctx.global_context.llbc_global_decls ctx.fun_decl let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = let type_params = ctx.fun_decl.signature.type_params in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in - let gid_conv = ctx.fun_context.gid_conv in - PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params + let global_decls = ctx.global_context.llbc_global_decls in + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params let ty_to_string (ctx : bs_ctx) (ty : ty) : string = let fmt = bs_ctx_to_pp_ast_formatter ctx in @@ -166,16 +170,16 @@ let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = let type_params = sg.type_params in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in - let gid_conv = ctx.fun_context.gid_conv in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params in + let global_decls = ctx.global_context.llbc_global_decls in + let fmt = PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = let type_params = def.signature.type_params in let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in - let gid_conv = ctx.fun_context.gid_conv in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params in + let global_decls = ctx.global_context.llbc_global_decls in + let fmt = PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params in PrintPure.fun_decl_to_string fmt def (* TODO: move *) @@ -1666,7 +1670,6 @@ let translate_fun_decl (config : config) (ctx : bs_ctx) (* Lookup the signature *) let signature = bs_ctx_lookup_local_function_sig def_id bid ctx in (* Translate the body, if there is *) - let is_global = def.A.is_global in let body = match body with | None -> None @@ -1727,7 +1730,7 @@ let translate_fun_decl (config : config) (ctx : bs_ctx) Some { inputs; inputs_lvs; body } in (* Assemble the declaration *) - let def = { def_id; back_id = bid; basename; signature; is_global; body } in + let def = { def_id; back_id = bid; basename; signature; is_global_body = def.is_global_body; body } in (* Debugging *) log#ldebug (lazy diff --git a/src/Translate.ml b/src/Translate.ml index 9412b8b8..a6477e7f 100644 --- a/src/Translate.ml +++ b/src/Translate.ml @@ -63,10 +63,9 @@ let translate_function_to_symbolics (config : C.partial_config) ("translate_function_to_symbolics: " ^ Print.fun_name_to_string fdef.A.name)); - let { type_context; fun_context } = trans_ctx in + let { type_context; fun_context; global_context } = trans_ctx in let fun_context = { C.fun_decls = fun_context.fun_decls; - C.gid_conv = fun_context.gid_conv; } in match fdef.body with @@ -76,7 +75,8 @@ let translate_function_to_symbolics (config : C.partial_config) let synthesize = true in let evaluate gid = let inputs, symb = - evaluate_function_symbolic config synthesize type_context fun_context + evaluate_function_symbolic config synthesize + type_context fun_context global_context fdef gid in (inputs, Option.get symb) @@ -110,7 +110,7 @@ let translate_function_to_pure (config : C.partial_config) (lazy ("translate_function_to_pure: " ^ Print.fun_name_to_string fdef.A.name)); - let { type_context; fun_context } = trans_ctx in + let { type_context; fun_context; global_context } = trans_ctx in let def_id = fdef.def_id in (* Compute the symbolic ASTs, if the function is transparent *) @@ -142,7 +142,10 @@ let translate_function_to_pure (config : C.partial_config) SymbolicToPure.llbc_fun_decls = fun_context.fun_decls; fun_sigs; fun_infos = fun_context.fun_infos; - gid_conv = fun_context.gid_conv; + } + in + let global_context = { + SymbolicToPure.llbc_global_decls = global_context.global_decls } in let ctx = @@ -156,6 +159,7 @@ let translate_function_to_pure (config : C.partial_config) state_var; type_context; fun_context; + global_context; fun_decl = fdef; forward_inputs = []; (* Empty for now *) @@ -293,14 +297,13 @@ let translate_module_to_pure (config : C.partial_config) log#ldebug (lazy "translate_module_to_pure"); (* Compute the type and function contexts *) - let type_context, fun_context = compute_type_fun_contexts m in + let type_context, fun_context, global_context = compute_type_fun_contexts m in let fun_infos = FA.analyze_module m fun_context.C.fun_decls use_state in let fun_context = { fun_decls = fun_context.fun_decls; fun_infos; - gid_conv = m.gid_conv; } in - let trans_ctx = { type_context; fun_context } in + let trans_ctx = { type_context; fun_context; global_context } in (* Translate all the type definitions *) let type_decls = SymbolicToPure.translate_type_decls m.types in @@ -495,7 +498,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) if ((not is_opaque) && config.extract_transparent) || (is_opaque && config.extract_opaque) - then if def.is_global + then if def.is_global_body then ExtractToFStar.extract_global_decl ctx.extract_ctx fmt qualif def else ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif has_decr_clause def ) diff --git a/src/TranslateCore.ml b/src/TranslateCore.ml index 047219ad..e77445cd 100644 --- a/src/TranslateCore.ml +++ b/src/TranslateCore.ml @@ -16,11 +16,16 @@ type type_context = C.type_context [@@deriving show] type fun_context = { fun_decls : A.fun_decl A.FunDeclId.Map.t; fun_infos : FA.fun_info A.FunDeclId.Map.t; - gid_conv : A.global_id_converter; } [@@deriving show] -type trans_ctx = { type_context : type_context; fun_context : fun_context } +type global_context = C.global_context [@@deriving show] + +type trans_ctx = { + type_context : type_context; + fun_context : fun_context; + global_context : global_context +} type pure_fun_translation = Pure.fun_decl * Pure.fun_decl list @@ -40,16 +45,16 @@ let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = let type_params = sg.type_params in let type_decls = ctx.type_context.type_decls in let fun_decls = ctx.fun_context.fun_decls in - let gid_conv = ctx.fun_context.gid_conv in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params in + let global_decls = ctx.global_context.global_decls in + let fmt = PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = let type_params = def.signature.type_params in let type_decls = ctx.type_context.type_decls in let fun_decls = ctx.fun_context.fun_decls in - let gid_conv = ctx.fun_context.gid_conv in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls gid_conv type_params in + let global_decls = ctx.global_context.global_decls in + let fmt = PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params in PrintPure.fun_decl_to_string fmt def let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = -- cgit v1.2.3 From fe7949c350bb3c5e2b9990ab3594b256194c3f0b Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Mon, 25 Jul 2022 14:22:52 +0200 Subject: Apply minor changes from PR comments --- src/FunsAnalysis.ml | 9 +-------- src/LlbcAst.ml | 8 ++++---- src/PureToExtract.ml | 4 ++-- src/PureTypeCheck.ml | 7 ++++++- src/SymbolicToPure.ml | 12 ++++++++++-- 5 files changed, 23 insertions(+), 17 deletions(-) (limited to 'src') diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index 034575c0..427175de 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -56,12 +56,6 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) inherit [_] iter_statement as super method may_fail b = - (* The fail flag is disabled for globals : the global body is - * normalised into its declaration, which is always successful. - * (we check that it is successful in the extracted code: if it is - * not, it leads to a type-checking error in the generated files) - *) - if f.is_global_body then () else can_fail := !can_fail || b method! visit_Assert env a = @@ -104,11 +98,10 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) (* Opaque function *) obj#may_fail true; stateful := use_state - | Some body -> obj#visit_statement () body.body); + | Some body -> obj#visit_statement () body.body) (* We ignore on purpose functions that cannot fail: the result of the analysis * is not used yet to adjust the translation so that the functions which * syntactically can't fail don't use an error monad. *) - can_fail := not f.is_global_body in List.iter visit_fun d; { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } diff --git a/src/LlbcAst.ml b/src/LlbcAst.ml index aa9b0665..94566f9b 100644 --- a/src/LlbcAst.ml +++ b/src/LlbcAst.ml @@ -37,7 +37,7 @@ type assumed_fun_id = type fun_id = Regular of FunDeclId.id | Assumed of assumed_fun_id [@@deriving show, ord] -type assign_global = { +type global_assignment = { dst : VarId.id; global : GlobalDeclId.id; } @@ -84,7 +84,7 @@ class ['self] iter_statement_base = object (_self : 'self) inherit [_] VisitorsRuntime.iter - method visit_assign_global : 'env -> assign_global -> unit = fun _ _ -> () + method visit_global_assignment : 'env -> global_assignment -> unit = fun _ _ -> () method visit_place : 'env -> place -> unit = fun _ _ -> () @@ -108,7 +108,7 @@ class ['self] map_statement_base = object (_self : 'self) inherit [_] VisitorsRuntime.map - method visit_assign_global : 'env -> assign_global -> assign_global = fun _ x -> x + method visit_global_assignment : 'env -> global_assignment -> global_assignment = fun _ x -> x method visit_place : 'env -> place -> place = fun _ x -> x @@ -131,7 +131,7 @@ class ['self] map_statement_base = type statement = | Assign of place * rvalue - | AssignGlobal of assign_global + | AssignGlobal of global_assignment | FakeRead of place | SetDiscriminant of place * VariantId.id | Drop of place diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml index 7a10bb6b..2d76f348 100644 --- a/src/PureToExtract.ml +++ b/src/PureToExtract.ml @@ -671,7 +671,7 @@ let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = TODO: move all those helpers. *) let default_fun_suffix - (is_global : bool) + (is_global_body : bool) (num_region_groups : int) (rg : region_group_info option) ((keep_fwd, num_backs) : bool * int) @@ -691,7 +691,7 @@ let default_fun_suffix we could not add the "_fwd" suffix) to prevent name clashes between definitions (in particular between type and function definitions). *) - if is_global then "_c" else + if is_global_body then "_body" else match rg with | None -> "_fwd" | Some rg -> diff --git a/src/PureTypeCheck.ml b/src/PureTypeCheck.ml index 90b9ab09..c63814eb 100644 --- a/src/PureTypeCheck.ml +++ b/src/PureTypeCheck.ml @@ -40,6 +40,7 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) type tc_ctx = { type_decls : type_decl TypeDeclId.Map.t; (** The type declarations *) + global_decls : A.global_decl A.GlobalDeclId.Map.t; (** The global declarations *) env : ty VarId.Map.t; (** Environment from variables to types *) } @@ -111,7 +112,11 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = check_texpression ctx body | Qualif qualif -> ( match qualif.id with - | Func _ | Global _ -> () (* TODO *) + | Func _ -> () (* TODO *) + | Global id -> + let global = A.GlobalDeclId.Map.find id ctx.global_decls in + (* TODO: something like assert (global.ty = e.ty) *) + failwith "PureTypeCheck.ml:118" | Proj { adt_id = proj_adt_id; field_id } -> (* Note we can only project fields of structures (not enumerations) *) (* Deconstruct the projector type *) diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml index 7d9e2906..83cce3e9 100644 --- a/src/SymbolicToPure.ml +++ b/src/SymbolicToPure.ml @@ -127,13 +127,21 @@ type bs_ctx = { let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = let env = VarId.Map.empty in - let ctx = { PureTypeCheck.type_decls = ctx.type_context.type_decls; env } in + let ctx = { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env + } in let _ = PureTypeCheck.check_typed_pattern ctx v in () let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = let env = VarId.Map.empty in - let ctx = { PureTypeCheck.type_decls = ctx.type_context.type_decls; env } in + let ctx = { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env + } in PureTypeCheck.check_texpression ctx e (* TODO: move *) -- cgit v1.2.3 From af298b98b7efe8c6dba86a99dc9c07c3c43ce14d Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Thu, 28 Jul 2022 14:24:41 +0200 Subject: Always put can_fail to true, specialize global traduction to concrete function call and symbolic fresh value --- src/FunsAnalysis.ml | 2 ++ src/InterpreterStatements.ml | 25 ++++++++++++++++--------- 2 files changed, 18 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index 427175de..3a6ad542 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -104,6 +104,8 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) * syntactically can't fail don't use an error monad. *) in List.iter visit_fun d; + (* Not-failing functions are not handled yet. *) + can_fail := true; { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } in diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 6a0b81f3..3f6470b9 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -832,15 +832,7 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = (* Compose and apply *) comp cf_eval_rvalue cf_assign cf ctx | A.AssignGlobal { dst; global } -> - (* What codegen do we want ? *) - let call : A.call = { - func = A.Regular (failwith "TODO InterpretStatements.ml:837"); - region_args = []; - type_args = []; - args = []; - dest = { var_id = dst; projection = [] }; - } in - eval_function_call config call cf ctx + eval_global config dst global cf ctx | A.FakeRead p -> let expand_prim_copy = false in let cf_prepare cf = @@ -918,6 +910,21 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = (* Compose and apply *) comp cc cf_eval_st cf ctx +and eval_global (config : C.config) (dest : V.VarId.id) (gid : LA.GlobalDeclId.id) : st_cm_fun = + fun cf ctx -> + let global = C.ctx_lookup_global_decl ctx gid in + let place = { E.var_id = dest; projection = [] } in + match config.mode with + | ConcreteMode -> + (* Treat the global as a function without arguments to call *) + (eval_local_function_call_concrete config global.body_id [] [] [] place) cf ctx + | SymbolicMode -> + (* Treat the global as a fresh symbolic value *) + let rty = ety_no_regions_to_rty global.ty in + let sval = mk_fresh_symbolic_value V.FunCallRet rty in + let sval = mk_typed_value_from_symbolic_value sval in + assign_to_place config sval place (cf Unit) ctx + (** Evaluate a switch *) and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) : st_cm_fun = -- cgit v1.2.3 From f9015d1e956ace6c875eb6a631caeac49cfb8148 Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Fri, 29 Jul 2022 16:04:49 +0200 Subject: Create global declaration group, address PR changes but introduce bugs --- src/ExtractToFStar.ml | 64 ++++++++++++++++++++++++-------------------- src/FunsAnalysis.ml | 13 ++++++--- src/Interpreter.ml | 4 +-- src/InterpreterStatements.ml | 7 ++++- src/LlbcOfJson.ml | 37 ++++++++++++------------- src/Modules.ml | 27 +++++++++++-------- src/PureToExtract.ml | 32 ++++++++++++++++------ src/PureTypeCheck.ml | 7 ++--- src/PureUtils.ml | 5 ++++ src/Translate.ml | 21 ++++++++++++--- 10 files changed, 134 insertions(+), 83 deletions(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 2c53e45b..a2b15ece 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -313,11 +313,15 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) (* Concatenate the elements *) String.concat "_" fname in - let fun_name (_fid : A.fun_id) (fname : fun_name) (is_global : bool) (num_rgs : int) + let global_name (name : global_name) : string = + let parts = List.map to_snake_case (get_name name) in + String.concat "_" parts + in + let fun_name (_fid : A.fun_id) (fname : fun_name) (num_rgs : int) (rg : region_group_info option) (filter_info : bool * int) : string = let fname = fun_name_to_snake_case fname in (* Compute the suffix *) - let suffix = default_fun_suffix is_global num_rgs rg filter_info in + let suffix = default_fun_suffix num_rgs rg filter_info in (* Concatenate *) fname ^ suffix in @@ -411,6 +415,7 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) variant_name; struct_constructor; type_name; + global_name; fun_name; decreases_clause_name; var_basename; @@ -839,6 +844,11 @@ let extract_adt_g_value ctx | _ -> raise (Failure "Inconsistent typed value") +(* Extract globals in the same way as variables *) +let extract_global (ctx : extraction_ctx) (fmt : F.formatter) + (id : A.GlobalDeclId.id) : unit = + F.pp_print_string fmt (ctx_get_global_decl id ctx) + (** [inside]: see [extract_ty]. As an pattern can introduce new variables, we return an extraction context @@ -907,12 +917,7 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) | Func fun_id -> extract_function_call ctx fmt inside fun_id qualif.type_args args | Global global_id -> - failwith "TODO ExtractToFStar.ml:911" - (* Previous code: - let fid = A.global_to_fun_id ctx.trans_ctx.fun_context.gid_conv global_id in - let fun_id = Regular (A.Regular fid, None) in - extract_function_call ctx fmt inside fun_id qualif.type_args args - *) + extract_global ctx fmt global_id | AdtCons adt_cons_id -> extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args args | Proj proj -> @@ -1353,6 +1358,7 @@ let extract_template_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (qualif : fun_decl_qualif) (has_decreases_clause : bool) (def : fun_decl) : unit = + assert (def.is_global_body); (* Retrieve the function name *) let def_name = ctx_get_local_function def.def_id def.back_id ctx in (* (* Add the type parameters - note that we need those bindings only for the @@ -1551,40 +1557,40 @@ let extract_global_definition (ctx : extraction_ctx) (fmt : F.formatter) `let x_c : int = eval_global x_body` *) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) - (qualif : fun_decl_qualif) (def : fun_decl) - : unit = - (* TODO Lookup LLBC decl *) - (* Sanity checks for globals *) - assert (def.is_global_body); - failwith "TODO ExtractToFStar.ml:1559" - (* Previous code: - assert (Option.is_none def.back_id); - assert (List.length def.signature.inputs = 0); - assert (List.length def.signature.doutputs = 1); - assert (List.length def.signature.type_params = 0); - assert (not def.signature.info.effect_info.can_fail); + (global : A.global_decl) (body : fun_decl) (interface : bool) : unit = + assert (body.is_global_body); + assert (Option.is_none body.back_id); + assert (List.length body.signature.inputs = 0); + assert (List.length body.signature.doutputs = 1); + assert (List.length body.signature.type_params = 0); (* Add a break then the name of the corresponding LLBC declaration *) F.pp_print_break fmt 0 0; - F.pp_print_string fmt ("(** [" ^ Print.fun_name_to_string def.basename ^ "] *)"); + F.pp_print_string fmt ("(** [" ^ Print.global_name_to_string global.name ^ "] *)"); F.pp_print_space fmt (); - let def_name = ctx_get_local_function def.def_id def.back_id ctx in - match def.body with + let decl_name = ctx_get_global_decl global.def_id ctx in + let body_name = ctx_get_global_body global.def_id ctx in + + let decl_ty, body_ty = + let ty = body.signature.output in + if body.signature.info.effect_info.can_fail + then (unwrap_result_ty ty, ty) + else (ty, mk_result_ty ty) + in + match body.body with | None -> - extract_global_definition ctx fmt qualif def_name def.signature.output None + let qualif = if interface then Val else AssumeVal in + extract_global_definition ctx fmt qualif decl_name decl_ty None | Some body -> - let body_name = global_decl_to_body_name def_name in - let body_ty = mk_result_ty def.signature.output in - extract_global_definition ctx fmt qualif body_name body_ty (Some (fun fmt -> + extract_global_definition ctx fmt Let body_name body_ty (Some (fun fmt -> extract_texpression ctx fmt false body.body )); F.pp_print_break fmt 0 0; - extract_global_definition ctx fmt qualif def_name def.signature.output (Some (fun fmt -> + extract_global_definition ctx fmt Let decl_name decl_ty (Some (fun fmt -> F.pp_print_string fmt ("eval_global " ^ body_name) )); F.pp_print_break fmt 0 0 - *) (** Extract a unit test, if the function is a unit function (takes no parameters, returns unit). diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index 3a6ad542..65a130c8 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -1,7 +1,7 @@ (** Compute various information, including: - can a function fail (by having `Fail` in its body, or transitively calling a function which can fail), false for globals - - can a function diverge (bu being recursive, containing a loop or + - can a function diverge (by being recursive, containing a loop or transitively calling a function which can diverge) - does a function perform stateful operations (i.e., do we need a state to translate it) @@ -26,7 +26,9 @@ type fun_info = { type modules_funs_info = fun_info FunDeclId.Map.t (** Various information about a module's functions *) -let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) +let analyze_module (m : llbc_module) + (funs_map : fun_decl FunDeclId.Map.t) + (globals_map : global_decl GlobalDeclId.Map.t) (use_state : bool) : modules_funs_info = let infos = ref FunDeclId.Map.empty in @@ -104,7 +106,7 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) * syntactically can't fail don't use an error monad. *) in List.iter visit_fun d; - (* Not-failing functions are not handled yet. *) + (* Non-failing functions are not handled yet. *) can_fail := true; { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } in @@ -126,6 +128,11 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) | Fun decl :: decls' -> analyze_fun_decl_group decl; analyze_decl_groups decls' + | Global id :: decls' -> + (* Analyze a global by analyzing its body function *) + let global = GlobalDeclId.Map.find id globals_map in + analyze_fun_decl_group (NonRec global.body_id); + analyze_decl_groups decls' in analyze_decl_groups m.declarations; diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 3610d486..51144ba2 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -15,9 +15,9 @@ let log = L.interpreter_log let compute_type_fun_contexts (m : M.llbc_module) : C.type_context * C.fun_context * C.global_context = - let type_decls_list, _ = M.split_declarations m.declarations in + let type_decls_list, _, _ = M.split_declarations m.declarations in let type_decls, fun_decls, global_decls = M.compute_defs_maps m in - let type_decls_groups, _funs_defs_groups = + let type_decls_groups, _funs_defs_groups, _globals_defs_groups = M.split_declarations_to_group_maps m.declarations in let type_infos = diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 3f6470b9..ffc47741 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -919,11 +919,16 @@ and eval_global (config : C.config) (dest : V.VarId.id) (gid : LA.GlobalDeclId.i (* Treat the global as a function without arguments to call *) (eval_local_function_call_concrete config global.body_id [] [] [] place) cf ctx | SymbolicMode -> + (* + let g = A.GlobalDeclId.Map.find gid ctx.global_context.global_decls in + (eval_local_function_call_symbolic config g.body_id [] [] [] place) cf ctx + *) + failwith "TODO Got error later in translate_fun_decl>meta>expansion ~> lookup_var_for_symbolic_value"; (* Treat the global as a fresh symbolic value *) let rty = ety_no_regions_to_rty global.ty in let sval = mk_fresh_symbolic_value V.FunCallRet rty in let sval = mk_typed_value_from_symbolic_value sval in - assign_to_place config sval place (cf Unit) ctx + (assign_to_place config sval place) (cf Unit) ctx (** Evaluate a switch *) and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) : diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml index f51c15be..be43ff54 100644 --- a/src/LlbcOfJson.ml +++ b/src/LlbcOfJson.ml @@ -698,18 +698,18 @@ let fun_declaration_group_of_json (js : json) : combine_error_msgs js "fun_declaration_group_of_json" (g_declaration_group_of_json A.FunDeclId.id_of_json js) -(* TODO Should a global declaration group be converted to its function bodies ? - It does not seems very clean. -*) -let global_declaration_group_of_json (js : json) (gid_conv : global_id_converter) : - (M.fun_declaration_group, string) result = +let global_declaration_group_of_json (js : json) : + (A.GlobalDeclId.id, string) result = combine_error_msgs js "global_declaration_group_of_json" - (g_declaration_group_of_json (fun js -> - let* id = A.GlobalDeclId.id_of_json js in - Ok (global_to_fun_id gid_conv id) - ) js) - -let declaration_group_of_json (js : json) (gid_conv : global_id_converter) : (M.declaration_group, string) result + (match js with + | `Assoc [ ("NonRec", `List [ id ]) ] -> + let* id = A.GlobalDeclId.id_of_json id in + Ok (id) + | `Assoc [ ("Rec", `List [ _ ]) ] -> + Error "got mutually dependent globals" + | _ -> Error "") + +let declaration_group_of_json (js : json) : (M.declaration_group, string) result = combine_error_msgs js "declaration_of_json" (match js with @@ -720,8 +720,8 @@ let declaration_group_of_json (js : json) (gid_conv : global_id_converter) : (M. let* decl = fun_declaration_group_of_json decl in Ok (M.Fun decl) | `Assoc [ ("Global", `List [ decl ]) ] -> - let* decl = global_declaration_group_of_json decl gid_conv in - Ok (M.Fun decl) + let* id = global_declaration_group_of_json decl in + Ok (M.Global id) | _ -> Error "") let length_of_json_list (js: json) : (int, string) result = @@ -741,15 +741,12 @@ let llbc_module_of_json (js : json) : (M.llbc_module, string) result = ("functions", functions); ("globals", globals); ] -> - let* fun_count = length_of_json_list functions in - let gid_conv = { fun_count } in let* name = string_of_json name in - let* declarations = - list_of_json (fun js -> declaration_group_of_json js gid_conv) declarations - in - let* types = list_of_json type_decl_of_json types in + let* declarations = list_of_json declaration_group_of_json declarations in + let* types = list_of_json type_decl_of_json types in let* functions = list_of_json fun_decl_of_json functions in - let* globals = list_of_json (fun js -> global_decl_of_json js gid_conv) globals in + let gid_conv = { fun_count = List.length functions } in + let* globals = list_of_json (fun js -> global_decl_of_json js gid_conv) globals in let globals, global_bodies = List.split globals in Ok { M.name; diff --git a/src/Modules.ml b/src/Modules.ml index 2f640636..009e1ba6 100644 --- a/src/Modules.ml +++ b/src/Modules.ml @@ -10,10 +10,11 @@ type type_declaration_group = TypeDeclId.id g_declaration_group type fun_declaration_group = FunDeclId.id g_declaration_group [@@deriving show] -(** Module declaration *) +(** Module declaration. Globals cannot be mutually dependent. *) type declaration_group = | Type of type_declaration_group | Fun of fun_declaration_group + | Global of GlobalDeclId.id [@@deriving show] type llbc_module = { @@ -44,26 +45,29 @@ let compute_defs_maps (m : llbc_module) : in (types_map, funs_map, globals_map) -(** Split a module's declarations between types and functions *) +(** Split a module's declarations between types, globals and functions *) let split_declarations (decls : declaration_group list) : - type_declaration_group list * fun_declaration_group list = + type_declaration_group list * fun_declaration_group list * GlobalDeclId.id list = let rec split decls = match decls with - | [] -> ([], []) + | [] -> ([], [], []) | d :: decls' -> ( - let types, funs = split decls' in + let types, funs, globals = split decls' in match d with - | Type decl -> (decl :: types, funs) - | Fun decl -> (types, decl :: funs)) + | Type decl -> (decl :: types, funs, globals) + | Fun decl -> (types, decl :: funs, globals) + | Global decl -> (types, funs, decl :: globals) + ) in split decls -(** Split a module's declarations into two maps from type/fun ids to +(** Split a module's declarations into three maps from type/fun/global ids to declaration groups. *) let split_declarations_to_group_maps (decls : declaration_group list) : type_declaration_group TypeDeclId.Map.t - * fun_declaration_group FunDeclId.Map.t = + * fun_declaration_group FunDeclId.Map.t + * GlobalDeclId.Set.t = let module G (M : Map.S) = struct let add_group (map : M.key g_declaration_group M.t) (group : M.key g_declaration_group) : M.key g_declaration_group M.t = @@ -75,9 +79,10 @@ let split_declarations_to_group_maps (decls : declaration_group list) : M.key g_declaration_group M.t = List.fold_left add_group M.empty groups end in - let types, funs = split_declarations decls in + let types, funs, globals = split_declarations decls in let module TG = G (TypeDeclId.Map) in let types = TG.create_map types in let module FG = G (FunDeclId.Map) in let funs = FG.create_map funs in - (types, funs) + let globals = GlobalDeclId.Set.of_list globals in + (types, funs, globals) diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml index 2d76f348..1dc7eae9 100644 --- a/src/PureToExtract.ml +++ b/src/PureToExtract.ml @@ -32,6 +32,8 @@ type name = Names.name type type_name = Names.type_name +type global_name = Names.global_name + type fun_name = Names.fun_name (* TODO: this should a module we give to a functor! *) @@ -71,10 +73,11 @@ type formatter = { *) type_name : type_name -> string; (** Provided a basename, compute a type name. *) + global_name : global_name -> string; + (** Provided a basename, compute a global name. *) fun_name : A.fun_id -> fun_name -> - bool -> int -> region_group_info option -> bool * int -> @@ -83,7 +86,6 @@ type formatter = { - function id: this is especially useful to identify whether the function is an assumed function or a local function - function basename - - flag indicating if the function is a global - number of region groups - region group information in case of a backward function (`None` if forward function) @@ -186,6 +188,7 @@ type formatter = { (** We use identifiers to look for name clashes *) type id = + | GlobalId of A.GlobalDeclId.id | FunId of A.fun_id * RegionGroupId.id option | DecreasesClauseId of A.fun_id (** The definition which provides the decreases/termination clause. @@ -342,6 +345,7 @@ type extraction_ctx = { (** Debugging function *) let id_to_string (id : id) (ctx : extraction_ctx) : string = + let global_decls = ctx.trans_ctx.global_context.global_decls in let fun_decls = ctx.trans_ctx.fun_context.fun_decls in let type_decls = ctx.trans_ctx.type_context.type_decls in (* TODO: factorize the pretty-printing with what is in PrintPure *) @@ -354,6 +358,9 @@ let id_to_string (id : id) (ctx : extraction_ctx) : string = | Tuple -> failwith "Unreachable" in match id with + | GlobalId gid -> + let name = (A.GlobalDeclId.Map.find gid global_decls).name in + "global name: " ^ Print.global_name_to_string name | FunId (fid, rg_id) -> let fun_name = match fid with @@ -442,6 +449,12 @@ let ctx_get (id : id) (ctx : extraction_ctx) : string = log#serror ("Could not find: " ^ id_to_string id ctx); raise Not_found +let ctx_get_global_decl (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = + ctx_get (GlobalId id) ctx ^ "_c" + +let ctx_get_global_body (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = + ctx_get (GlobalId id) ctx ^ "_body" + let ctx_get_function (id : A.fun_id) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = @@ -572,6 +585,10 @@ let ctx_add_decrases_clause (def : fun_decl) (ctx : extraction_ctx) : let name = ctx.fmt.decreases_clause_name def.def_id def.basename in ctx_add (DecreasesClauseId (A.Regular def.def_id)) name ctx +let ctx_add_global_decl (def : A.global_decl) (ctx : extraction_ctx) : + extraction_ctx = + ctx_add (GlobalId def.def_id) (ctx.fmt.global_name def.name) ctx + let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = (* Lookup the LLBC def to compute the region group information *) @@ -600,11 +617,12 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) in let def_id = A.Regular def_id in let name = - ctx.fmt.fun_name def_id def.basename def.is_global_body num_rgs rg_info (keep_fwd, num_backs) + ctx.fmt.fun_name def_id def.basename num_rgs rg_info (keep_fwd, num_backs) in - (* Add the function name *) - let ctx = ctx_add (FunId (def_id, def.back_id)) name ctx in - ctx + (* Add the function name if it's not a global *) + if def.is_global_body + then ctx + else ctx_add (FunId (def_id, def.back_id)) name ctx type names_map_init = { keywords : string list; @@ -671,7 +689,6 @@ let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = TODO: move all those helpers. *) let default_fun_suffix - (is_global_body : bool) (num_region_groups : int) (rg : region_group_info option) ((keep_fwd, num_backs) : bool * int) @@ -691,7 +708,6 @@ let default_fun_suffix we could not add the "_fwd" suffix) to prevent name clashes between definitions (in particular between type and function definitions). *) - if is_global_body then "_body" else match rg with | None -> "_fwd" | Some rg -> diff --git a/src/PureTypeCheck.ml b/src/PureTypeCheck.ml index c63814eb..39fb5073 100644 --- a/src/PureTypeCheck.ml +++ b/src/PureTypeCheck.ml @@ -112,11 +112,8 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = check_texpression ctx body | Qualif qualif -> ( match qualif.id with - | Func _ -> () (* TODO *) - | Global id -> - let global = A.GlobalDeclId.Map.find id ctx.global_decls in - (* TODO: something like assert (global.ty = e.ty) *) - failwith "PureTypeCheck.ml:118" + | Func _ -> () (* TODO *) + | Global _ -> () (* TODO *) | Proj { adt_id = proj_adt_id; field_id } -> (* Note we can only project fields of structures (not enumerations) *) (* Deconstruct the projector type *) diff --git a/src/PureUtils.ml b/src/PureUtils.ml index 8d3b5258..8a1c074d 100644 --- a/src/PureUtils.ml +++ b/src/PureUtils.ml @@ -399,6 +399,11 @@ let type_decl_is_enum (def : T.type_decl) : bool = let mk_state_ty : ty = Adt (Assumed State, []) let mk_result_ty (ty : ty) : ty = Adt (Assumed Result, [ ty ]) +let unwrap_result_ty (ty : ty) : ty = + match ty with + | Adt (Assumed Result, [ ty ]) -> ty + | _ -> failwith "not a result" + let mk_result_fail_texpression (ty : ty) : texpression = let type_args = [ ty ] in let ty = Adt (Assumed Result, type_args) in diff --git a/src/Translate.ml b/src/Translate.ml index a6477e7f..a936d626 100644 --- a/src/Translate.ml +++ b/src/Translate.ml @@ -298,7 +298,7 @@ let translate_module_to_pure (config : C.partial_config) (* Compute the type and function contexts *) let type_context, fun_context, global_context = compute_type_fun_contexts m in - let fun_infos = FA.analyze_module m fun_context.C.fun_decls use_state in + let fun_infos = FA.analyze_module m fun_context.C.fun_decls global_context.C.global_decls use_state in let fun_context = { fun_decls = fun_context.fun_decls; fun_infos; @@ -498,9 +498,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) if ((not is_opaque) && config.extract_transparent) || (is_opaque && config.extract_opaque) - then if def.is_global_body - then ExtractToFStar.extract_global_decl ctx.extract_ctx fmt qualif def - else ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif has_decr_clause def + then ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif has_decr_clause def ) fls); (* Insert unit tests if necessary *) @@ -512,6 +510,19 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) pure_ls in + (* TODO: Check correct behaviour with opaque globals *) + let export_global (id : A.GlobalDeclId.id) : unit = + let global_decls = ctx.extract_ctx.trans_ctx.global_context.global_decls in + let global = A.GlobalDeclId.Map.find id global_decls in + let (_, (body, body_backs)) = A.FunDeclId.Map.find global.body_id ctx.trans_funs in + assert (List.length body_backs = 0); + + let is_opaque = Option.is_none body.Pure.body in + if ((not is_opaque) && config.extract_transparent) + || (is_opaque && config.extract_opaque) + then ExtractToFStar.extract_global_decl ctx.extract_ctx fmt global body config.interface + in + let export_state_type () : unit = let qualif = if config.interface then ExtractToFStar.TypeVal @@ -547,6 +558,8 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) in (* Translate *) export_functions true pure_funs + | Global id -> + export_global id in (* If we need to export the state type: we try to export it after we defined -- cgit v1.2.3 From 3c5fb260012ee8bb8b9fd90bc4624d893ac7678a Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Mon, 8 Aug 2022 15:16:14 +0200 Subject: Register global names, one error remaining --- src/ExtractToFStar.ml | 5 +++++ src/InterpreterStatements.ml | 8 ++++++-- src/SymbolicToPure.ml | 8 +++++++- src/Translate.ml | 6 +++++- 4 files changed, 23 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index a2b15ece..c915aede 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -794,6 +794,11 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) (* Return *) ctx +(** Simply add the global name to the context. *) +let extract_global_decl_register_names (ctx : extraction_ctx) (def : A.global_decl) + : extraction_ctx = + ctx_add_global_decl def ctx + (** The following function factorizes the extraction of ADT values. Note that patterns can introduce new variables: we thus return an extraction diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index ffc47741..31c3aabb 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -919,16 +919,20 @@ and eval_global (config : C.config) (dest : V.VarId.id) (gid : LA.GlobalDeclId.i (* Treat the global as a function without arguments to call *) (eval_local_function_call_concrete config global.body_id [] [] [] place) cf ctx | SymbolicMode -> + (* Treat the global as a fresh symbolic value *) + (* let g = A.GlobalDeclId.Map.find gid ctx.global_context.global_decls in (eval_local_function_call_symbolic config g.body_id [] [] [] place) cf ctx - *) + failwith "TODO Got error later in translate_fun_decl>meta>expansion ~> lookup_var_for_symbolic_value"; - (* Treat the global as a fresh symbolic value *) + *) + let rty = ety_no_regions_to_rty global.ty in let sval = mk_fresh_symbolic_value V.FunCallRet rty in let sval = mk_typed_value_from_symbolic_value sval in (assign_to_place config sval place) (cf Unit) ctx + (** Evaluate a switch *) and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) : diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml index 83cce3e9..16e48aef 100644 --- a/src/SymbolicToPure.ml +++ b/src/SymbolicToPure.ml @@ -687,7 +687,13 @@ let fresh_vars (vars : (string option * ty) list) (ctx : bs_ctx) : List.fold_left_map (fun ctx (name, ty) -> fresh_var name ty ctx) ctx vars let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = - V.SymbolicValueId.Map.find sv.sv_id ctx.sv_to_var + try (V.SymbolicValueId.Map.find sv.sv_id ctx.sv_to_var) with + Not_found -> + print_endline ("Missing " ^ Print.V.show_symbolic_value sv); + V.SymbolicValueId.Map.iter (fun id (v : var) -> + print_endline (" -- " ^ (Option.value v.basename ~default:"")) + ) ctx.sv_to_var; + raise Not_found (** Peel boxes as long as the value is of the form `Box` *) let rec unbox_typed_value (v : V.typed_value) : V.typed_value = diff --git a/src/Translate.ml b/src/Translate.ml index a936d626..fdd6d05f 100644 --- a/src/Translate.ml +++ b/src/Translate.ml @@ -655,7 +655,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) m.declarations)) in - (* Register unique names for all the top-level types and functions. + (* Register unique names for all the top-level types, functions and globals. * Note that the order in which we generate the names doesn't matter: * we just need to generate a mapping from identifier to name, and make * sure there are no name clashes. *) @@ -677,6 +677,10 @@ let translate_module (filename : string) (dest_dir : string) (config : config) ctx trans_funs in + let ctx = List.fold_left + ExtractToFStar.extract_global_decl_register_names ctx m.globals + in + (* Open the output file *) (* First compute the filename by replacing the extension and converting the * case (rust module names are snake case) *) -- cgit v1.2.3 From cd754eabe3af025ca3465c5fc6d8cb48da66a1ae Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Wed, 10 Aug 2022 18:56:25 +0200 Subject: Corrected translation without using functions, remaining bug in hashmap translation --- src/ExtractToFStar.ml | 2 +- src/InterpreterBorrows.ml | 2 +- src/InterpreterStatements.ml | 17 ++++------------- src/InterpreterUtils.ml | 4 ++-- src/SymbolicAst.ml | 2 ++ src/SymbolicToPure.ml | 21 ++++++++++++++------- src/SynthesizeSymbolic.ml | 6 ++++++ src/Values.ml | 1 + 8 files changed, 31 insertions(+), 24 deletions(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index c915aede..f2c481c0 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -1363,7 +1363,7 @@ let extract_template_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (qualif : fun_decl_qualif) (has_decreases_clause : bool) (def : fun_decl) : unit = - assert (def.is_global_body); + assert (not def.is_global_body); (* Retrieve the function name *) let def_name = ctx_get_local_function def.def_id def.back_id ctx in (* (* Add the type parameters - note that we need those bindings only for the diff --git a/src/InterpreterBorrows.ml b/src/InterpreterBorrows.ml index a13ac786..6b920a51 100644 --- a/src/InterpreterBorrows.ml +++ b/src/InterpreterBorrows.ml @@ -436,7 +436,7 @@ let give_back_symbolic_value (_config : C.config) assert (sv.sv_id <> nsv.sv_id); (match nsv.sv_kind with | V.SynthInputGivenBack | V.SynthRetGivenBack | V.FunCallGivenBack -> () - | V.FunCallRet | V.SynthInput -> failwith "Unrechable"); + | V.FunCallRet | V.SynthInput | V.Global -> failwith "Unrechable"); (* Store the given-back value as a meta-value for synthesis purposes *) let mv = nsv in (* Substitution function, to replace the borrow projectors over symbolic values *) diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 31c3aabb..48620439 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -920,19 +920,10 @@ and eval_global (config : C.config) (dest : V.VarId.id) (gid : LA.GlobalDeclId.i (eval_local_function_call_concrete config global.body_id [] [] [] place) cf ctx | SymbolicMode -> (* Treat the global as a fresh symbolic value *) - - (* - let g = A.GlobalDeclId.Map.find gid ctx.global_context.global_decls in - (eval_local_function_call_symbolic config g.body_id [] [] [] place) cf ctx - - failwith "TODO Got error later in translate_fun_decl>meta>expansion ~> lookup_var_for_symbolic_value"; - *) - - let rty = ety_no_regions_to_rty global.ty in - let sval = mk_fresh_symbolic_value V.FunCallRet rty in - let sval = mk_typed_value_from_symbolic_value sval in - (assign_to_place config sval place) (cf Unit) ctx - + let sval = mk_fresh_symbolic_value V.Global (ety_no_regions_to_rty global.ty) in + let cc = assign_to_place config (mk_typed_value_from_symbolic_value sval) place in + let e = cc (cf Unit) ctx in + S.synthesize_global_eval gid sval e (** Evaluate a switch *) and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) : diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 47323cc2..6ef66f1d 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -238,8 +238,8 @@ let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) raise Found else () | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack - | V.SynthRetGivenBack -> - () + | V.SynthRetGivenBack -> () + | V.Global -> () end in (* We use exceptions *) diff --git a/src/SymbolicAst.ml b/src/SymbolicAst.ml index 9cab092d..fd490e43 100644 --- a/src/SymbolicAst.ml +++ b/src/SymbolicAst.ml @@ -65,6 +65,8 @@ type expression = | Panic | FunCall of call * expression | EndAbstraction of V.abs * expression + | EvalGlobal of A.GlobalDeclId.id * V.symbolic_value * expression + (** A fresh symbolic value for the global *) | Expansion of mplace option * V.symbolic_value * expansion (** Expansion of a symbolic value. diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml index 16e48aef..81af6a8b 100644 --- a/src/SymbolicToPure.ml +++ b/src/SymbolicToPure.ml @@ -687,13 +687,7 @@ let fresh_vars (vars : (string option * ty) list) (ctx : bs_ctx) : List.fold_left_map (fun ctx (name, ty) -> fresh_var name ty ctx) ctx vars let lookup_var_for_symbolic_value (sv : V.symbolic_value) (ctx : bs_ctx) : var = - try (V.SymbolicValueId.Map.find sv.sv_id ctx.sv_to_var) with - Not_found -> - print_endline ("Missing " ^ Print.V.show_symbolic_value sv); - V.SymbolicValueId.Map.iter (fun id (v : var) -> - print_endline (" -- " ^ (Option.value v.basename ~default:"")) - ) ctx.sv_to_var; - raise Not_found + V.SymbolicValueId.Map.find sv.sv_id ctx.sv_to_var (** Peel boxes as long as the value is of the form `Box` *) let rec unbox_typed_value (v : V.typed_value) : V.typed_value = @@ -1080,6 +1074,7 @@ let rec translate_expression (config : config) (e : S.expression) (ctx : bs_ctx) | Panic -> translate_panic ctx | FunCall (call, e) -> translate_function_call config call e ctx | EndAbstraction (abs, e) -> translate_end_abstraction config abs e ctx + | EvalGlobal (gid, sv, e) -> translate_global_eval config gid sv e ctx | Expansion (p, sv, exp) -> translate_expansion config p sv exp ctx | Meta (meta, e) -> translate_meta config meta e ctx @@ -1466,6 +1461,18 @@ and translate_end_abstraction (config : config) (abs : V.abs) (e : S.expression) mk_let monadic given_back (mk_texpression_from_var input_var) e) given_back_inputs next_e +and translate_global_eval (config : config) (gid : A.GlobalDeclId.id) + (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) + : texpression = + let (ctx, var) = fresh_var_for_symbolic_value sval ctx in + let decl = A.GlobalDeclId.Map.find gid ctx.global_context.llbc_global_decls in + let global_expr = { id = Global gid; type_args = [] } in + (* We use translate_fwd_ty to translate the global type *) + let ty = ctx_translate_fwd_ty ctx decl.ty in + let gval = { e = Qualif global_expr; ty } in + let e = translate_expression config e ctx in + mk_let false (mk_typed_pattern_from_var var None) gval e + and translate_expansion (config : config) (p : S.mplace option) (sv : V.symbolic_value) (exp : S.expansion) (ctx : bs_ctx) : texpression = (* Translate the scrutinee *) diff --git a/src/SynthesizeSymbolic.ml b/src/SynthesizeSymbolic.ml index 95da38e6..fa244649 100644 --- a/src/SynthesizeSymbolic.ml +++ b/src/SynthesizeSymbolic.ml @@ -114,6 +114,12 @@ let synthesize_function_call (call_id : call_id) in Some (FunCall (call, expr)) +let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) (expr : expression option) + : expression option = + match expr with + | None -> None + | Some e -> Some (EvalGlobal (gid, dest, e)) + let synthesize_regular_function_call (fun_id : A.fun_id) (call_id : V.FunCallId.id) (abstractions : V.AbstractionId.id list) (type_params : T.ety list) (args : V.typed_value list) diff --git a/src/Values.ml b/src/Values.ml index 4585b443..13cd2580 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -65,6 +65,7 @@ type sv_kind = *) | SynthInputGivenBack (** The value was given back upon ending one of the input abstractions *) + | Global (** The value is a global *) [@@deriving show] type symbolic_value = { -- cgit v1.2.3 From fa491861faed3ba5ed4fe806b55bea663a29579c Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Thu, 11 Aug 2022 10:39:04 +0200 Subject: Correct assertion for stateless globals --- src/FunsAnalysis.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index 65a130c8..39fa316d 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -94,7 +94,7 @@ let analyze_module (m : llbc_module) super#visit_Loop env loop end in - assert (not f.is_global_body || not use_state); + assert (not f.is_global_body || not !stateful); (match f.body with | None -> (* Opaque function *) -- cgit v1.2.3 From e7f76a4e46f24f54e5b49efee40e33e11128f49c Mon Sep 17 00:00:00 2001 From: Sidney Congard Date: Thu, 11 Aug 2022 18:04:10 +0200 Subject: Correct last PR remarks --- src/ExtractToFStar.ml | 24 ++++++++---------------- src/PureToExtract.ml | 16 +++++++++------- 2 files changed, 17 insertions(+), 23 deletions(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index f2c481c0..7f271f02 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -797,7 +797,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) (** Simply add the global name to the context. *) let extract_global_decl_register_names (ctx : extraction_ctx) (def : A.global_decl) : extraction_ctx = - ctx_add_global_decl def ctx + ctx_add_global_decl_body def ctx (** The following function factorizes the extraction of ADT values. @@ -852,7 +852,7 @@ let extract_adt_g_value (* Extract globals in the same way as variables *) let extract_global (ctx : extraction_ctx) (fmt : F.formatter) (id : A.GlobalDeclId.id) : unit = - F.pp_print_string fmt (ctx_get_global_decl id ctx) + F.pp_print_string fmt (ctx_get_global id ctx) (** [inside]: see [extract_ty]. @@ -1491,16 +1491,8 @@ let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 -(* Change the suffix from "_c" to "_body" *) -let global_decl_to_body_name (decl : string) : string = - (* The declaration length without the global suffix *) - let base_len = String.length decl - 2 in - (* TODO: Use String.ends_with instead when a more recent version of OCaml is used *) - assert (String.sub decl base_len 2 = "_c"); - (String.sub decl 0 base_len) ^ "_body" - (** Extract a global definition of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) -let extract_global_definition (ctx : extraction_ctx) (fmt : F.formatter) +let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) (qualif : fun_decl_qualif) (name : string) (ty : ty) (extract_body : (F.formatter -> unit) Option.t) : unit = @@ -1574,8 +1566,8 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) F.pp_print_string fmt ("(** [" ^ Print.global_name_to_string global.name ^ "] *)"); F.pp_print_space fmt (); - let decl_name = ctx_get_global_decl global.def_id ctx in - let body_name = ctx_get_global_body global.def_id ctx in + let decl_name = ctx_get_global global.def_id ctx in + let body_name = ctx_get_function (Regular global.body_id) None ctx in let decl_ty, body_ty = let ty = body.signature.output in @@ -1586,13 +1578,13 @@ let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) match body.body with | None -> let qualif = if interface then Val else AssumeVal in - extract_global_definition ctx fmt qualif decl_name decl_ty None + extract_global_decl_body ctx fmt qualif decl_name decl_ty None | Some body -> - extract_global_definition ctx fmt Let body_name body_ty (Some (fun fmt -> + extract_global_decl_body ctx fmt Let body_name body_ty (Some (fun fmt -> extract_texpression ctx fmt false body.body )); F.pp_print_break fmt 0 0; - extract_global_definition ctx fmt Let decl_name decl_ty (Some (fun fmt -> + extract_global_decl_body ctx fmt Let decl_name decl_ty (Some (fun fmt -> F.pp_print_string fmt ("eval_global " ^ body_name) )); F.pp_print_break fmt 0 0 diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml index 1dc7eae9..b7d45deb 100644 --- a/src/PureToExtract.ml +++ b/src/PureToExtract.ml @@ -449,12 +449,9 @@ let ctx_get (id : id) (ctx : extraction_ctx) : string = log#serror ("Could not find: " ^ id_to_string id ctx); raise Not_found -let ctx_get_global_decl (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = - ctx_get (GlobalId id) ctx ^ "_c" +let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = + ctx_get (GlobalId id) ctx -let ctx_get_global_body (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = - ctx_get (GlobalId id) ctx ^ "_body" - let ctx_get_function (id : A.fun_id) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = @@ -585,9 +582,14 @@ let ctx_add_decrases_clause (def : fun_decl) (ctx : extraction_ctx) : let name = ctx.fmt.decreases_clause_name def.def_id def.basename in ctx_add (DecreasesClauseId (A.Regular def.def_id)) name ctx -let ctx_add_global_decl (def : A.global_decl) (ctx : extraction_ctx) : +let ctx_add_global_decl_body (def : A.global_decl) (ctx : extraction_ctx) : extraction_ctx = - ctx_add (GlobalId def.def_id) (ctx.fmt.global_name def.name) ctx + let name = ctx.fmt.global_name def.name in + let decl = GlobalId def.def_id in + let body = FunId (Regular def.body_id, None) in + let ctx = ctx_add decl (name ^ "_c") ctx in + let ctx = ctx_add body (name ^ "_body") ctx in + ctx let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = -- cgit v1.2.3 From ba68c1ab4a7bd7817068d34d44fca38e4c547d90 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:25:47 +0200 Subject: Update src/Translate.ml --- src/Translate.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Translate.ml b/src/Translate.ml index fdd6d05f..25aff2b2 100644 --- a/src/Translate.ml +++ b/src/Translate.ml @@ -655,7 +655,7 @@ let translate_module (filename : string) (dest_dir : string) (config : config) m.declarations)) in - (* Register unique names for all the top-level types, functions and globals. + (* Register unique names for all the top-level types, globals and functions. * Note that the order in which we generate the names doesn't matter: * we just need to generate a mapping from identifier to name, and make * sure there are no name clashes. *) -- cgit v1.2.3 From 9dc3b26ecf2bba6993febaca816c6797147ee7b9 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:26:00 +0200 Subject: Update src/TypesUtils.ml --- src/TypesUtils.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml index 8d0624ee..8088be7f 100644 --- a/src/TypesUtils.ml +++ b/src/TypesUtils.ml @@ -100,7 +100,7 @@ let rty_regions_intersect (ty : rty) (regions : RegionId.Set.t) : bool = let ty_regions = rty_regions ty in not (RegionId.Set.disjoint ty_regions regions) -(** Convert an [ety], containing no region variables, to an [rty] or [sty]. +(** Convert an [ety], containing no region variables, to an [rty] or an [sty]. In practice, it is the identity. *) -- cgit v1.2.3 From 512b1ff5747f6c805e72d6847f4a6a10bffade7f Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:26:14 +0200 Subject: Update src/SymbolicAst.ml --- src/SymbolicAst.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/SymbolicAst.ml b/src/SymbolicAst.ml index fd490e43..ec2a80ca 100644 --- a/src/SymbolicAst.ml +++ b/src/SymbolicAst.ml @@ -66,7 +66,7 @@ type expression = | FunCall of call * expression | EndAbstraction of V.abs * expression | EvalGlobal of A.GlobalDeclId.id * V.symbolic_value * expression - (** A fresh symbolic value for the global *) + (** Evaluate a global to a fresh symbolic value *) | Expansion of mplace option * V.symbolic_value * expansion (** Expansion of a symbolic value. -- cgit v1.2.3 From f76262172b1331c2e3b4d27bce777f30c0ca7967 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:26:39 +0200 Subject: Update src/ExtractToFStar.ml --- src/ExtractToFStar.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 7f271f02..29203bc4 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -1491,7 +1491,7 @@ let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (* Add breaks to insert new lines between definitions *) F.pp_print_break fmt 0 0 -(** Extract a global definition of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) +(** Extract a global declaration body of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) (qualif : fun_decl_qualif) (name : string) (ty : ty) (extract_body : (F.formatter -> unit) Option.t) -- cgit v1.2.3 From 763e4e641f2dc349bee1820d2c5e4310fc2f07fa Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:26:58 +0200 Subject: Update src/ExtractToFStar.ml --- src/ExtractToFStar.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 29203bc4..059a7f2e 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -1547,7 +1547,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) However, generate its body separately from its declaration to extract the result value. For example, - `let x = 3` + `static X: u32 = 3;` will be translated to `let x_body : result int = Return 3` -- cgit v1.2.3 From 08e46b0dae3532ed646e6d39894726700d066a50 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:27:12 +0200 Subject: Update src/ExtractToFStar.ml --- src/ExtractToFStar.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 059a7f2e..5e33566f 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -1546,7 +1546,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) This has similarity with the function extraction above (without parameters). However, generate its body separately from its declaration to extract the result value. - For example, + For example in Rust, `static X: u32 = 3;` will be translated to -- cgit v1.2.3 From 5080fa9c40fb8adfd87bd957cd1beca6c7e8e98e Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:27:29 +0200 Subject: Update src/ExtractToFStar.ml --- src/ExtractToFStar.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 5e33566f..f2ea9945 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -1549,7 +1549,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) For example in Rust, `static X: u32 = 3;` - will be translated to + will be translated to: `let x_body : result int = Return 3` `let x_c : int = eval_global x_body` *) -- cgit v1.2.3 From be9c975fa7df858083e48aa7bd42fff475abeac4 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:27:48 +0200 Subject: Update src/ExtractToFStar.ml --- src/ExtractToFStar.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index f2ea9945..131b2e8b 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -1550,7 +1550,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) `static X: u32 = 3;` will be translated to: - `let x_body : result int = Return 3` + `let x_body : result u32 = Return 3` `let x_c : int = eval_global x_body` *) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) -- cgit v1.2.3 From 58c5065954d4bc616481efee35cbd22a1d354c6d Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:28:05 +0200 Subject: Update src/ExtractToFStar.ml --- src/ExtractToFStar.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 131b2e8b..6b60906b 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -1551,7 +1551,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) will be translated to: `let x_body : result u32 = Return 3` - `let x_c : int = eval_global x_body` + `let x_c : u32 = eval_global x_body` *) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : A.global_decl) (body : fun_decl) (interface : bool) : unit = -- cgit v1.2.3 From 21a9ed3c7393199eb695db8ac93783651103d1e5 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:28:19 +0200 Subject: Update src/ExtractToFStar.ml --- src/ExtractToFStar.ml | 1 - 1 file changed, 1 deletion(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 6b60906b..d6b9437e 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -1543,7 +1543,6 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) F.pp_close_box fmt () (** Extract a global declaration. - This has similarity with the function extraction above (without parameters). However, generate its body separately from its declaration to extract the result value. For example in Rust, -- cgit v1.2.3 From 0b90d3fbf2d15d88cbc4530253a1a2c77983bd91 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:28:35 +0200 Subject: Update src/ExtractToFStar.ml --- src/ExtractToFStar.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index d6b9437e..8b7ac244 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -1543,7 +1543,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) F.pp_close_box fmt () (** Extract a global declaration. - However, generate its body separately from its declaration to extract the result value. + We generate the body which computes the global value separately from the value declaration itself. For example in Rust, `static X: u32 = 3;` -- cgit v1.2.3 From 692babd59421995809ce0cf7d4354a591dc73fe3 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:28:52 +0200 Subject: Update src/FunsAnalysis.ml --- src/FunsAnalysis.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index 39fa316d..33f77f89 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -1,6 +1,6 @@ (** Compute various information, including: - can a function fail (by having `Fail` in its body, or transitively - calling a function which can fail), false for globals + calling a function which can fail - this is false for globals) - can a function diverge (by being recursive, containing a loop or transitively calling a function which can diverge) - does a function perform stateful operations (i.e., do we need a state -- cgit v1.2.3 From 573dc89a52224be4c0887ae98d677305605b0539 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:29:32 +0200 Subject: Update src/FunsAnalysis.ml --- src/FunsAnalysis.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index 33f77f89..5a37a0a3 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -94,6 +94,7 @@ let analyze_module (m : llbc_module) super#visit_Loop env loop end in + (* Sanity check: global bodies don't contain stateful calls *) assert (not f.is_global_body || not !stateful); (match f.body with | None -> -- cgit v1.2.3 From 798876feed0e06923f4066a8d04b87081fef72e0 Mon Sep 17 00:00:00 2001 From: Son HO Date: Thu, 22 Sep 2022 16:35:46 +0200 Subject: Update src/ExtractToFStar.ml --- src/ExtractToFStar.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 8b7ac244..06f82ac4 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -856,7 +856,7 @@ let extract_global (ctx : extraction_ctx) (fmt : F.formatter) (** [inside]: see [extract_ty]. - As an pattern can introduce new variables, we return an extraction context + As a pattern can introduce new variables, we return an extraction context updated with new bindings. *) let rec extract_typed_pattern (ctx : extraction_ctx) (fmt : F.formatter) -- cgit v1.2.3 From 53481c4326c0f3c17b372880a9a19ee2eb45907d Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 22 Sep 2022 17:36:37 +0200 Subject: Update FunsAnalysis --- src/FunsAnalysis.ml | 50 ++++++++++++++++++++++++++------------------------ 1 file changed, 26 insertions(+), 24 deletions(-) (limited to 'src') diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index 5a37a0a3..2aebc144 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -26,10 +26,9 @@ type fun_info = { type modules_funs_info = fun_info FunDeclId.Map.t (** Various information about a module's functions *) -let analyze_module (m : llbc_module) - (funs_map : fun_decl FunDeclId.Map.t) - (globals_map : global_decl GlobalDeclId.Map.t) - (use_state : bool) : modules_funs_info = +let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) + (globals_map : global_decl GlobalDeclId.Map.t) (use_state : bool) : + modules_funs_info = let infos = ref FunDeclId.Map.empty in let register_info (id : FunDeclId.id) (info : fun_info) : unit = @@ -56,21 +55,19 @@ let analyze_module (m : llbc_module) let obj = object (self) inherit [_] iter_statement as super - - method may_fail b = - can_fail := !can_fail || b + method may_fail b = can_fail := !can_fail || b method! visit_Assert env a = self#may_fail true; super#visit_Assert env a - method! visit_rvalue _env rv = - match rv with - | Use _ | Ref _ | Discriminant _ | Aggregate _ -> () - | UnaryOp (uop, _) -> can_fail := EU.unop_can_fail uop || !can_fail - | BinaryOp (bop, _, _) -> - can_fail := EU.binop_can_fail bop || !can_fail - + method! visit_rvalue _env rv = + match rv with + | Use _ | Ref _ | Discriminant _ | Aggregate _ -> () + | UnaryOp (uop, _) -> can_fail := EU.unop_can_fail uop || !can_fail + | BinaryOp (bop, _, _) -> + can_fail := EU.binop_can_fail bop || !can_fail + method! visit_Call env call = (match call.func with | Regular id -> @@ -95,20 +92,25 @@ let analyze_module (m : llbc_module) end in (* Sanity check: global bodies don't contain stateful calls *) - assert (not f.is_global_body || not !stateful); - (match f.body with + assert ((not f.is_global_body) || not !stateful); + match f.body with | None -> - (* Opaque function *) + (* Opaque function: we consider they fail by default *) obj#may_fail true; - stateful := use_state - | Some body -> obj#visit_statement () body.body) - (* We ignore on purpose functions that cannot fail: the result of the analysis - * is not used yet to adjust the translation so that the functions which - * syntactically can't fail don't use an error monad. *) + stateful := (not f.is_global_body) && use_state + | Some body -> obj#visit_statement () body.body in List.iter visit_fun d; - (* Non-failing functions are not handled yet. *) - can_fail := true; + (* We need to know if the declaration group contains a global - note that + * groups containing globals contain exactly one declaration *) + let is_global_body = List.exists (fun f -> f.is_global_body) d in + assert ((not is_global_body) || List.length d == 1); + (* We ignore on purpose functions that cannot fail and consider they *can* + * fail: the result of the analysis is not used yet to adjust the translation + * so that the functions which syntactically can't fail don't use an error monad. + * However, we do keep the result of the analysis for global bodies. + * *) + can_fail := (not is_global_body) || !can_fail; { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } in -- cgit v1.2.3 From f106fd4ad0a221611c840bf0af0b1c2ff23f3d0f Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 22 Sep 2022 17:44:04 +0200 Subject: Make minor modifications --- src/ExtractToFStar.ml | 56 +++++++++++----------- src/InterpreterExpressions.ml | 15 +++--- src/InterpreterStatements.ml | 26 +++++++---- src/LlbcOfJson.ml | 105 +++++++++++++++++++++++------------------- src/Modules.ml | 20 ++++---- src/PureUtils.ml | 2 +- 6 files changed, 117 insertions(+), 107 deletions(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index 06f82ac4..eb88b916 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -314,6 +314,8 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) String.concat "_" fname in let global_name (name : global_name) : string = + (* Converting to snake case also lowercases the letters (in Rust, global + * names are written in capital letters). *) let parts = List.map to_snake_case (get_name name) in String.concat "_" parts in @@ -326,7 +328,8 @@ let mk_formatter (ctx : trans_ctx) (crate_name : string) fname ^ suffix in - let decreases_clause_name (_fid : A.FunDeclId.id) (fname : fun_name) : string = + let decreases_clause_name (_fid : A.FunDeclId.id) (fname : fun_name) : string + = let fname = fun_name_to_snake_case fname in (* Compute the suffix *) let suffix = "_decreases" in @@ -795,8 +798,8 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) ctx (** Simply add the global name to the context. *) -let extract_global_decl_register_names (ctx : extraction_ctx) (def : A.global_decl) - : extraction_ctx = +let extract_global_decl_register_names (ctx : extraction_ctx) + (def : A.global_decl) : extraction_ctx = ctx_add_global_decl_body def ctx (** The following function factorizes the extraction of ADT values. @@ -851,7 +854,7 @@ let extract_adt_g_value (* Extract globals in the same way as variables *) let extract_global (ctx : extraction_ctx) (fmt : F.formatter) - (id : A.GlobalDeclId.id) : unit = + (id : A.GlobalDeclId.id) : unit = F.pp_print_string fmt (ctx_get_global id ctx) (** [inside]: see [extract_ty]. @@ -921,13 +924,11 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) match qualif.id with | Func fun_id -> extract_function_call ctx fmt inside fun_id qualif.type_args args - | Global global_id -> - extract_global ctx fmt global_id + | Global global_id -> extract_global ctx fmt global_id | AdtCons adt_cons_id -> extract_adt_cons ctx fmt inside adt_cons_id qualif.type_args args | Proj proj -> - extract_field_projector ctx fmt inside app proj qualif.type_args args - ) + extract_field_projector ctx fmt inside app proj qualif.type_args args) | _ -> (* "Regular" expression *) (* Open parentheses *) @@ -1493,9 +1494,8 @@ let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (** Extract a global declaration body of the shape "QUALIF NAME : TYPE = BODY" with a custom body extractor *) let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) - (qualif : fun_decl_qualif) (name : string) (ty : ty) - (extract_body : (F.formatter -> unit) Option.t) - : unit = + (qualif : fun_decl_qualif) (name : string) (ty : ty) + (extract_body : (F.formatter -> unit) Option.t) : unit = let is_opaque = Option.is_none extract_body in (* Open the definition box (depth=0) *) @@ -1505,7 +1505,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) F.pp_open_hovbox fmt ctx.indent_incr; (* Print "QUALIF NAME " *) F.pp_print_string fmt (fun_decl_qualif_keyword qualif ^ " " ^ name); - F.pp_print_space fmt (); + F.pp_print_space fmt (); (* Open ": TYPE =" box (depth=2) *) F.pp_open_hvbox fmt 0; @@ -1523,8 +1523,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) if not is_opaque then ( (* Print " =" *) F.pp_print_space fmt (); - F.pp_print_string fmt "="; - ); + F.pp_print_string fmt "="); (* Close ": TYPE =" box (depth=2) *) F.pp_close_box fmt (); (* Close "QUALIF NAME : TYPE =" box (depth=1) *) @@ -1537,8 +1536,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) (* Print "BODY" *) (Option.get extract_body) fmt; (* Close "BODY" box (depth=1) *) - F.pp_close_box fmt () - ); + F.pp_close_box fmt ()); (* Close the definition box (depth=0) *) F.pp_close_box fmt () @@ -1554,39 +1552,37 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : A.global_decl) (body : fun_decl) (interface : bool) : unit = - assert (body.is_global_body); + assert body.is_global_body; assert (Option.is_none body.back_id); assert (List.length body.signature.inputs = 0); assert (List.length body.signature.doutputs = 1); assert (List.length body.signature.type_params = 0); (* Add a break then the name of the corresponding LLBC declaration *) - F.pp_print_break fmt 0 0; - F.pp_print_string fmt ("(** [" ^ Print.global_name_to_string global.name ^ "] *)"); - F.pp_print_space fmt (); + F.pp_print_break fmt 0 0; + F.pp_print_string fmt + ("(** [" ^ Print.global_name_to_string global.name ^ "] *)"); + F.pp_print_space fmt (); let decl_name = ctx_get_global global.def_id ctx in let body_name = ctx_get_function (Regular global.body_id) None ctx in let decl_ty, body_ty = let ty = body.signature.output in - if body.signature.info.effect_info.can_fail - then (unwrap_result_ty ty, ty) - else (ty, mk_result_ty ty) + if body.signature.info.effect_info.can_fail then (unwrap_result_ty ty, ty) + else (ty, mk_result_ty ty) in match body.body with | None -> let qualif = if interface then Val else AssumeVal in extract_global_decl_body ctx fmt qualif decl_name decl_ty None | Some body -> - extract_global_decl_body ctx fmt Let body_name body_ty (Some (fun fmt -> - extract_texpression ctx fmt false body.body - )); + extract_global_decl_body ctx fmt Let body_name body_ty + (Some (fun fmt -> extract_texpression ctx fmt false body.body)); F.pp_print_break fmt 0 0; - extract_global_decl_body ctx fmt Let decl_name decl_ty (Some (fun fmt -> - F.pp_print_string fmt ("eval_global " ^ body_name) - )); - F.pp_print_break fmt 0 0 + extract_global_decl_body ctx fmt Let decl_name decl_ty + (Some (fun fmt -> F.pp_print_string fmt ("eval_global " ^ body_name))); + F.pp_print_break fmt 0 0 (** Extract a unit test, if the function is a unit function (takes no parameters, returns unit). diff --git a/src/InterpreterExpressions.ml b/src/InterpreterExpressions.ml index 4598895e..4a4f3353 100644 --- a/src/InterpreterExpressions.ml +++ b/src/InterpreterExpressions.ml @@ -110,14 +110,13 @@ let access_rplace_reorganize (config : C.config) (expand_prim_copy : bool) ctx (** Convert an operand constant operand value to a typed value *) -let constant_to_typed_value (ty : T.ety) - (cv : V.constant_value) : V.typed_value = +let constant_to_typed_value (ty : T.ety) (cv : V.constant_value) : V.typed_value + = (* Check the type while converting - we actually need some information - * contained in the type *) + * contained in the type *) log#ldebug (lazy - ("constant_to_typed_value:" ^ "\n- cv: " - ^ PV.constant_value_to_string cv)); + ("constant_to_typed_value:" ^ "\n- cv: " ^ PV.constant_value_to_string cv)); match (ty, cv) with (* Scalar, boolean... *) | T.Bool, Bool v -> { V.value = V.Concrete (Bool v); ty } @@ -128,10 +127,8 @@ let constant_to_typed_value (ty : T.ety) assert (int_ty = v.int_ty); assert (check_scalar_value_in_range v); { V.value = V.Concrete (V.Scalar v); ty } - (* Remaining cases (invalid) - listing as much as we can on purpose - (allows to catch errors at compilation if the definitions change) *) - | _, _ -> - failwith "Improperly typed constant value" + (* Remaining cases (invalid) *) + | _, _ -> failwith "Improperly typed constant value" (** Reorganize the environment in preparation for the evaluation of an operand. diff --git a/src/InterpreterStatements.ml b/src/InterpreterStatements.ml index 48620439..34310ea1 100644 --- a/src/InterpreterStatements.ml +++ b/src/InterpreterStatements.ml @@ -831,8 +831,7 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = (* Compose and apply *) comp cf_eval_rvalue cf_assign cf ctx - | A.AssignGlobal { dst; global } -> - eval_global config dst global cf ctx + | A.AssignGlobal { dst; global } -> eval_global config dst global cf ctx | A.FakeRead p -> let expand_prim_copy = false in let cf_prepare cf = @@ -910,20 +909,27 @@ let rec eval_statement (config : C.config) (st : A.statement) : st_cm_fun = (* Compose and apply *) comp cc cf_eval_st cf ctx -and eval_global (config : C.config) (dest : V.VarId.id) (gid : LA.GlobalDeclId.id) : st_cm_fun = +and eval_global (config : C.config) (dest : V.VarId.id) + (gid : LA.GlobalDeclId.id) : st_cm_fun = fun cf ctx -> let global = C.ctx_lookup_global_decl ctx gid in let place = { E.var_id = dest; projection = [] } in match config.mode with | ConcreteMode -> - (* Treat the global as a function without arguments to call *) - (eval_local_function_call_concrete config global.body_id [] [] [] place) cf ctx + (* Treat the evaluation of the global as a call to the global body (without arguments) *) + (eval_local_function_call_concrete config global.body_id [] [] [] place) + cf ctx | SymbolicMode -> - (* Treat the global as a fresh symbolic value *) - let sval = mk_fresh_symbolic_value V.Global (ety_no_regions_to_rty global.ty) in - let cc = assign_to_place config (mk_typed_value_from_symbolic_value sval) place in - let e = cc (cf Unit) ctx in - S.synthesize_global_eval gid sval e + (* Generate a fresh symbolic value. In the translation, this fresh symbolic value will be + * defined as equal to the value of the global (see `S.synthesize_global_eval`). *) + let sval = + mk_fresh_symbolic_value V.Global (ety_no_regions_to_rty global.ty) + in + let cc = + assign_to_place config (mk_typed_value_from_symbolic_value sval) place + in + let e = cc (cf Unit) ctx in + S.synthesize_global_eval gid sval e (** Evaluate a switch *) and eval_switch (config : C.config) (op : E.operand) (tgts : A.switch_targets) : diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml index be43ff54..846d7232 100644 --- a/src/LlbcOfJson.ml +++ b/src/LlbcOfJson.ml @@ -394,7 +394,7 @@ let constant_value_of_json (js : json) : (V.constant_value, string) result = let* v = string_of_json v in Ok (V.String v) | _ -> Error "") - + let operand_of_json (js : json) : (E.operand, string) result = combine_error_msgs js "operand_of_json" (match js with @@ -599,10 +599,8 @@ and switch_targets_of_json (js : json) : (A.switch_targets, string) result = | `Assoc [ ("SwitchInt", `List [ int_ty; tgts; otherwise ]) ] -> let* int_ty = integer_type_of_json int_ty in let* tgts = - list_of_json ( - pair_of_json - (list_of_json scalar_value_of_json) - statement_of_json) + list_of_json + (pair_of_json (list_of_json scalar_value_of_json) statement_of_json) tgts in let* otherwise = statement_of_json otherwise in @@ -633,47 +631,47 @@ let fun_decl_of_json (js : json) : (A.fun_decl, string) result = let* name = fun_name_of_json name in let* signature = fun_sig_of_json signature in let* body = option_of_json fun_body_of_json body in - Ok { A.def_id; name; signature; body; is_global_body = false; } + Ok { A.def_id; name; signature; body; is_global_body = false } | _ -> Error "") (* Strict type for the number of function declarations (see [global_to_fun_id] below) *) -type global_id_converter = { fun_count : int } -[@@deriving show] +type global_id_converter = { fun_count : int } [@@deriving show] (** Converts a global id to its corresponding function id. To do so, it adds the global id to the number of function declarations : - We have the bijection `global_id <=> fun_id + fun_id_count`. + We have the bijection `global_fun_id <=> global_id + fun_id_count`. *) -let global_to_fun_id (conv : global_id_converter) (gid : A.GlobalDeclId.id) : A.FunDeclId.id = - A.FunDeclId.of_int ((A.GlobalDeclId.to_int gid) + conv.fun_count) +let global_to_fun_id (conv : global_id_converter) (gid : A.GlobalDeclId.id) : + A.FunDeclId.id = + A.FunDeclId.of_int (A.GlobalDeclId.to_int gid + conv.fun_count) (* Converts a global declaration to a function declaration. *) -let global_decl_of_json (js : json) (gid_conv : global_id_converter) : (A.global_decl * A.fun_decl, string) result = +let global_decl_of_json (js : json) (gid_conv : global_id_converter) : + (A.global_decl * A.fun_decl, string) result = combine_error_msgs js "global_decl_of_json" (match js with - | `Assoc - [ - ("def_id", def_id); - ("name", name); - ("ty", ty); - ("body", body); - ] -> + | `Assoc [ ("def_id", def_id); ("name", name); ("ty", ty); ("body", body) ] + -> let* global_id = A.GlobalDeclId.id_of_json def_id in let fun_id = global_to_fun_id gid_conv global_id in let* name = fun_name_of_json name in let* ty = ety_of_json ty in let* body = option_of_json fun_body_of_json body in - let signature : A.fun_sig = { - region_params = []; - num_early_bound_regions = 0; - regions_hierarchy = []; - type_params = []; - inputs = []; - output = TU.ety_no_regions_to_sty ty; - } in - Ok ({ A.def_id = global_id; body_id = fun_id; name; ty; }, - { A.def_id = fun_id; name; signature; body; is_global_body = true; }) + let signature : A.fun_sig = + { + region_params = []; + num_early_bound_regions = 0; + regions_hierarchy = []; + type_params = []; + inputs = []; + output = TU.ety_no_regions_to_sty ty; + } + in + Ok + ( { A.def_id = global_id; body_id = fun_id; name; ty }, + { A.def_id = fun_id; name; signature; body; is_global_body = true } + ) | _ -> Error "") let g_declaration_group_of_json (id_of_json : json -> ('id, string) result) @@ -701,13 +699,12 @@ let fun_declaration_group_of_json (js : json) : let global_declaration_group_of_json (js : json) : (A.GlobalDeclId.id, string) result = combine_error_msgs js "global_declaration_group_of_json" - (match js with - | `Assoc [ ("NonRec", `List [ id ]) ] -> - let* id = A.GlobalDeclId.id_of_json id in - Ok (id) - | `Assoc [ ("Rec", `List [ _ ]) ] -> - Error "got mutually dependent globals" - | _ -> Error "") + (match js with + | `Assoc [ ("NonRec", `List [ id ]) ] -> + let* id = A.GlobalDeclId.id_of_json id in + Ok id + | `Assoc [ ("Rec", `List [ _ ]) ] -> Error "got mutually dependent globals" + | _ -> Error "") let declaration_group_of_json (js : json) : (M.declaration_group, string) result = @@ -724,11 +721,11 @@ let declaration_group_of_json (js : json) : (M.declaration_group, string) result Ok (M.Global id) | _ -> Error "") -let length_of_json_list (js: json) : (int, string) result = +let length_of_json_list (js : json) : (int, string) result = combine_error_msgs js "get_json_list_len" (match js with - | `List jsl -> Ok (List.length jsl) - | _ -> Error ("not a list: " ^ show js)) + | `List jsl -> Ok (List.length jsl) + | _ -> Error ("not a list: " ^ show js)) let llbc_module_of_json (js : json) : (M.llbc_module, string) result = combine_error_msgs js "llbc_module_of_json" @@ -741,18 +738,30 @@ let llbc_module_of_json (js : json) : (M.llbc_module, string) result = ("functions", functions); ("globals", globals); ] -> + (* We first deserialize the declaration groups (which simply contain ids) + * and all the declarations *butù* the globals *) let* name = string_of_json name in - let* declarations = list_of_json declaration_group_of_json declarations in + let* declarations = + list_of_json declaration_group_of_json declarations + in let* types = list_of_json type_decl_of_json types in let* functions = list_of_json fun_decl_of_json functions in + (* When deserializing the globals, we split the global declarations + * between the globals themselves and their bodies, which are simply + * functions with no arguments. We add the global bodies to the list + * of function declarations: the (fresh) ids we use for those bodies + * are simply given by: `num_functions + global_id` *) let gid_conv = { fun_count = List.length functions } in - let* globals = list_of_json (fun js -> global_decl_of_json js gid_conv) globals in + let* globals = + list_of_json (fun js -> global_decl_of_json js gid_conv) globals + in let globals, global_bodies = List.split globals in - Ok { - M.name; - declarations; - types; - functions = functions @ global_bodies; - globals; - } + Ok + { + M.name; + declarations; + types; + functions = functions @ global_bodies; + globals; + } | _ -> Error "") diff --git a/src/Modules.ml b/src/Modules.ml index 009e1ba6..7f372d09 100644 --- a/src/Modules.ml +++ b/src/Modules.ml @@ -7,10 +7,9 @@ type 'id g_declaration_group = NonRec of 'id | Rec of 'id list type type_declaration_group = TypeDeclId.id g_declaration_group [@@deriving show] -type fun_declaration_group = FunDeclId.id g_declaration_group -[@@deriving show] +type fun_declaration_group = FunDeclId.id g_declaration_group [@@deriving show] -(** Module declaration. Globals cannot be mutually dependent. *) +(** Module declaration. Globals cannot be mutually recursive. *) type declaration_group = | Type of type_declaration_group | Fun of fun_declaration_group @@ -27,7 +26,9 @@ type llbc_module = { (** LLBC module - TODO: rename to crate *) let compute_defs_maps (m : llbc_module) : - type_decl TypeDeclId.Map.t * fun_decl FunDeclId.Map.t * global_decl GlobalDeclId.Map.t = + type_decl TypeDeclId.Map.t + * fun_decl FunDeclId.Map.t + * global_decl GlobalDeclId.Map.t = let types_map = List.fold_left (fun m (def : type_decl) -> TypeDeclId.Map.add def.def_id def m) @@ -45,9 +46,11 @@ let compute_defs_maps (m : llbc_module) : in (types_map, funs_map, globals_map) -(** Split a module's declarations between types, globals and functions *) +(** Split a module's declarations between types, functions and globals *) let split_declarations (decls : declaration_group list) : - type_declaration_group list * fun_declaration_group list * GlobalDeclId.id list = + type_declaration_group list + * fun_declaration_group list + * GlobalDeclId.id list = let rec split decls = match decls with | [] -> ([], [], []) @@ -56,8 +59,7 @@ let split_declarations (decls : declaration_group list) : match d with | Type decl -> (decl :: types, funs, globals) | Fun decl -> (types, decl :: funs, globals) - | Global decl -> (types, funs, decl :: globals) - ) + | Global decl -> (types, funs, decl :: globals)) in split decls @@ -66,7 +68,7 @@ let split_declarations (decls : declaration_group list) : *) let split_declarations_to_group_maps (decls : declaration_group list) : type_declaration_group TypeDeclId.Map.t - * fun_declaration_group FunDeclId.Map.t + * fun_declaration_group FunDeclId.Map.t * GlobalDeclId.Set.t = let module G (M : Map.S) = struct let add_group (map : M.key g_declaration_group M.t) diff --git a/src/PureUtils.ml b/src/PureUtils.ml index 8a1c074d..e72ff9d7 100644 --- a/src/PureUtils.ml +++ b/src/PureUtils.ml @@ -402,7 +402,7 @@ let mk_result_ty (ty : ty) : ty = Adt (Assumed Result, [ ty ]) let unwrap_result_ty (ty : ty) : ty = match ty with | Adt (Assumed Result, [ ty ]) -> ty - | _ -> failwith "not a result" + | _ -> failwith "not a result type" let mk_result_fail_texpression (ty : ty) : texpression = let type_args = [ ty ] in -- cgit v1.2.3 From c8ccd864e1fa6de3241d9dba184cf8ee4101e421 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 22 Sep 2022 17:52:27 +0200 Subject: Make minor cleanup --- src/ExtractToFStar.ml | 6 ++--- src/FunsAnalysis.ml | 10 ++++----- src/Interpreter.ml | 52 ++++++++++++++++++++++++------------------ src/LlbcAst.ml | 31 ++++++++------------------ src/LlbcOfJson.ml | 11 ++++++--- src/Pure.ml | 2 +- src/PureToExtract.ml | 26 ++++++--------------- src/Substitute.ml | 6 +++-- src/SymbolicToPure.ml | 62 ++++++++++++++++++++++++++++++--------------------- src/Translate.ml | 59 +++++++++++++++++++++++++----------------------- src/TypesUtils.ml | 1 - 11 files changed, 135 insertions(+), 131 deletions(-) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index eb88b916..ec0f88a4 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -800,7 +800,7 @@ let extract_fun_decl_register_names (ctx : extraction_ctx) (keep_fwd : bool) (** Simply add the global name to the context. *) let extract_global_decl_register_names (ctx : extraction_ctx) (def : A.global_decl) : extraction_ctx = - ctx_add_global_decl_body def ctx + ctx_add_global_decl_and_body def ctx (** The following function factorizes the extraction of ADT values. @@ -1364,7 +1364,7 @@ let extract_template_decreases_clause (ctx : extraction_ctx) (fmt : F.formatter) let extract_fun_decl (ctx : extraction_ctx) (fmt : F.formatter) (qualif : fun_decl_qualif) (has_decreases_clause : bool) (def : fun_decl) : unit = - assert (not def.is_global_body); + assert (not def.is_global_decl_body); (* Retrieve the function name *) let def_name = ctx_get_local_function def.def_id def.back_id ctx in (* (* Add the type parameters - note that we need those bindings only for the @@ -1552,7 +1552,7 @@ let extract_global_decl_body (ctx : extraction_ctx) (fmt : F.formatter) *) let extract_global_decl (ctx : extraction_ctx) (fmt : F.formatter) (global : A.global_decl) (body : fun_decl) (interface : bool) : unit = - assert body.is_global_body; + assert body.is_global_decl_body; assert (Option.is_none body.back_id); assert (List.length body.signature.inputs = 0); assert (List.length body.signature.doutputs = 1); diff --git a/src/FunsAnalysis.ml b/src/FunsAnalysis.ml index 2aebc144..615f45b3 100644 --- a/src/FunsAnalysis.ml +++ b/src/FunsAnalysis.ml @@ -92,25 +92,25 @@ let analyze_module (m : llbc_module) (funs_map : fun_decl FunDeclId.Map.t) end in (* Sanity check: global bodies don't contain stateful calls *) - assert ((not f.is_global_body) || not !stateful); + assert ((not f.is_global_decl_body) || not !stateful); match f.body with | None -> (* Opaque function: we consider they fail by default *) obj#may_fail true; - stateful := (not f.is_global_body) && use_state + stateful := (not f.is_global_decl_body) && use_state | Some body -> obj#visit_statement () body.body in List.iter visit_fun d; (* We need to know if the declaration group contains a global - note that * groups containing globals contain exactly one declaration *) - let is_global_body = List.exists (fun f -> f.is_global_body) d in - assert ((not is_global_body) || List.length d == 1); + let is_global_decl_body = List.exists (fun f -> f.is_global_decl_body) d in + assert ((not is_global_decl_body) || List.length d == 1); (* We ignore on purpose functions that cannot fail and consider they *can* * fail: the result of the analysis is not used yet to adjust the translation * so that the functions which syntactically can't fail don't use an error monad. * However, we do keep the result of the analysis for global bodies. * *) - can_fail := (not is_global_body) || !can_fail; + can_fail := (not is_global_decl_body) || !can_fail; { can_fail = !can_fail; stateful = !stateful; divergent = !divergent } in diff --git a/src/Interpreter.ml b/src/Interpreter.ml index 51144ba2..3a2939ef 100644 --- a/src/Interpreter.ml +++ b/src/Interpreter.ml @@ -13,7 +13,7 @@ module SA = SymbolicAst (** The local logger *) let log = L.interpreter_log -let compute_type_fun_contexts (m : M.llbc_module) : +let compute_type_fun_global_contexts (m : M.llbc_module) : C.type_context * C.fun_context * C.global_context = let type_decls_list, _, _ = M.split_declarations m.declarations in let type_decls, fun_decls, global_decls = M.compute_defs_maps m in @@ -28,10 +28,8 @@ let compute_type_fun_contexts (m : M.llbc_module) : let global_context = { C.global_decls } in (type_context, fun_context, global_context) -let initialize_eval_context - (type_context : C.type_context) - (fun_context : C.fun_context) - (global_context : C.global_context) +let initialize_eval_context (type_context : C.type_context) + (fun_context : C.fun_context) (global_context : C.global_context) (type_vars : T.type_var list) : C.eval_ctx = C.reset_global_counters (); { @@ -56,12 +54,9 @@ let initialize_eval_context - the list of symbolic values introduced for the input values - the instantiated function signature *) -let initialize_symbolic_context_for_fun - (type_context : C.type_context) - (fun_context : C.fun_context) - (global_context : C.global_context) - (fdef : A.fun_decl) : - C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = +let initialize_symbolic_context_for_fun (type_context : C.type_context) + (fun_context : C.fun_context) (global_context : C.global_context) + (fdef : A.fun_decl) : C.eval_ctx * V.symbolic_value list * A.inst_fun_sig = (* The abstractions are not initialized the same way as for function * calls: they contain *loan* projectors, because they "provide" us * with the input values (which behave as if they had been returned @@ -75,7 +70,10 @@ let initialize_symbolic_context_for_fun * *) let sg = fdef.signature in (* Create the context *) - let ctx = initialize_eval_context type_context fun_context global_context sg.type_params in + let ctx = + initialize_eval_context type_context fun_context global_context + sg.type_params + in (* Instantiate the signature *) let type_params = List.map (fun tv -> T.TypeVar tv.T.index) sg.type_params in let inst_sg = instantiate_fun_sig type_params sg in @@ -212,8 +210,9 @@ let evaluate_function_symbolic_synthesize_backward_from_return - the symbolic AST generated by the symbolic execution *) let evaluate_function_symbolic (config : C.partial_config) (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) (global_context : C.global_context) - (fdef : A.fun_decl) (back_id : T.RegionGroupId.id option) : + (type_context : C.type_context) (fun_context : C.fun_context) + (global_context : C.global_context) (fdef : A.fun_decl) + (back_id : T.RegionGroupId.id option) : V.symbolic_value list * SA.expression option = (* Debug *) let name_to_string () = @@ -226,7 +225,8 @@ let evaluate_function_symbolic (config : C.partial_config) (synthesize : bool) (* Create the evaluation context *) let ctx, input_svs, inst_sg = - initialize_symbolic_context_for_fun type_context fun_context global_context fdef + initialize_symbolic_context_for_fun type_context fun_context global_context + fdef in (* Create the continuation to finish the evaluation *) @@ -293,8 +293,12 @@ module Test = struct assert (body.A.arg_count = 0); (* Create the evaluation context *) - let type_context, fun_context, global_context = compute_type_fun_contexts m in - let ctx = initialize_eval_context type_context fun_context global_context [] in + let type_context, fun_context, global_context = + compute_type_fun_global_contexts m + in + let ctx = + initialize_eval_context type_context fun_context global_context [] + in (* Insert the (uninitialized) local variables *) let ctx = C.ctx_push_uninitialized_vars ctx body.A.locals in @@ -338,15 +342,16 @@ module Test = struct (** Execute the symbolic interpreter on a function. *) let test_function_symbolic (config : C.partial_config) (synthesize : bool) - (type_context : C.type_context) (fun_context : C.fun_context) (global_context : C.global_context) - (fdef : A.fun_decl) : unit = + (type_context : C.type_context) (fun_context : C.fun_context) + (global_context : C.global_context) (fdef : A.fun_decl) : unit = (* Debug *) log#ldebug (lazy ("test_function_symbolic: " ^ Print.fun_name_to_string fdef.A.name)); (* Evaluate *) let evaluate = - evaluate_function_symbolic config synthesize type_context fun_context global_context fdef + evaluate_function_symbolic config synthesize type_context fun_context + global_context fdef in (* Execute the forward function *) let _ = evaluate None in @@ -376,12 +381,15 @@ module Test = struct in (* Filter the opaque functions *) let no_loop_funs = List.filter fun_decl_is_transparent no_loop_funs in - let type_context, fun_context, global_context = compute_type_fun_contexts m in + let type_context, fun_context, global_context = + compute_type_fun_global_contexts m + in let test_fun (def : A.fun_decl) : unit = (* Execute the function - note that as the symbolic interpreter explores * all the path, some executions are expected to "panic": we thus don't * check the return value *) - test_function_symbolic config synthesize type_context fun_context global_context def + test_function_symbolic config synthesize type_context fun_context + global_context def in List.iter test_fun no_loop_funs end diff --git a/src/LlbcAst.ml b/src/LlbcAst.ml index 94566f9b..ccc870dc 100644 --- a/src/LlbcAst.ml +++ b/src/LlbcAst.ml @@ -3,7 +3,6 @@ open Types open Values open Expressions open Identifiers - module FunDeclId = IdGen () module GlobalDeclId = IdGen () @@ -37,10 +36,7 @@ type assumed_fun_id = type fun_id = Regular of FunDeclId.id | Assumed of assumed_fun_id [@@deriving show, ord] -type global_assignment = { - dst : VarId.id; - global : GlobalDeclId.id; -} +type global_assignment = { dst : VarId.id; global : GlobalDeclId.id } [@@deriving show] type assertion = { cond : operand; expected : bool } [@@deriving show] @@ -84,22 +80,16 @@ class ['self] iter_statement_base = object (_self : 'self) inherit [_] VisitorsRuntime.iter - method visit_global_assignment : 'env -> global_assignment -> unit = fun _ _ -> () + method visit_global_assignment : 'env -> global_assignment -> unit = + fun _ _ -> () method visit_place : 'env -> place -> unit = fun _ _ -> () - method visit_rvalue : 'env -> rvalue -> unit = fun _ _ -> () - method visit_id : 'env -> VariantId.id -> unit = fun _ _ -> () - method visit_assertion : 'env -> assertion -> unit = fun _ _ -> () - method visit_operand : 'env -> operand -> unit = fun _ _ -> () - method visit_call : 'env -> call -> unit = fun _ _ -> () - method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () - method visit_scalar_value : 'env -> scalar_value -> unit = fun _ _ -> () end @@ -108,18 +98,15 @@ class ['self] map_statement_base = object (_self : 'self) inherit [_] VisitorsRuntime.map - method visit_global_assignment : 'env -> global_assignment -> global_assignment = fun _ x -> x + method visit_global_assignment + : 'env -> global_assignment -> global_assignment = + fun _ x -> x method visit_place : 'env -> place -> place = fun _ x -> x - method visit_rvalue : 'env -> rvalue -> rvalue = fun _ x -> x - method visit_id : 'env -> VariantId.id -> VariantId.id = fun _ x -> x - method visit_assertion : 'env -> assertion -> assertion = fun _ x -> x - method visit_operand : 'env -> operand -> operand = fun _ x -> x - method visit_call : 'env -> call -> call = fun _ x -> x method visit_integer_type : 'env -> integer_type -> integer_type = @@ -190,14 +177,14 @@ type fun_decl = { name : fun_name; signature : fun_sig; body : fun_body option; - is_global_body : bool; + is_global_decl_body : bool; } [@@deriving show] type global_decl = { def_id : GlobalDeclId.id; - body_id: FunDeclId.id; + body_id : FunDeclId.id; name : global_name; - ty: ety; + ty : ety; } [@@deriving show] diff --git a/src/LlbcOfJson.ml b/src/LlbcOfJson.ml index 846d7232..4e10c642 100644 --- a/src/LlbcOfJson.ml +++ b/src/LlbcOfJson.ml @@ -631,7 +631,7 @@ let fun_decl_of_json (js : json) : (A.fun_decl, string) result = let* name = fun_name_of_json name in let* signature = fun_sig_of_json signature in let* body = option_of_json fun_body_of_json body in - Ok { A.def_id; name; signature; body; is_global_body = false } + Ok { A.def_id; name; signature; body; is_global_decl_body = false } | _ -> Error "") (* Strict type for the number of function declarations (see [global_to_fun_id] below) *) @@ -670,8 +670,13 @@ let global_decl_of_json (js : json) (gid_conv : global_id_converter) : in Ok ( { A.def_id = global_id; body_id = fun_id; name; ty }, - { A.def_id = fun_id; name; signature; body; is_global_body = true } - ) + { + A.def_id = fun_id; + name; + signature; + body; + is_global_decl_body = true; + } ) | _ -> Error "") let g_declaration_group_of_json (id_of_json : json -> ('id, string) result) diff --git a/src/Pure.ml b/src/Pure.ml index 5244b0bc..ced56c6a 100644 --- a/src/Pure.ml +++ b/src/Pure.ml @@ -575,6 +575,6 @@ type fun_decl = { (to identify the forward/backward functions) later. *) signature : fun_sig; - is_global_body : bool; + is_global_decl_body : bool; body : fun_body option; } diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml index b7d45deb..255d4e1b 100644 --- a/src/PureToExtract.ml +++ b/src/PureToExtract.ml @@ -29,11 +29,8 @@ module StringSet = Collections.MakeSet (Collections.OrderedString) module StringMap = Collections.MakeMap (Collections.OrderedString) type name = Names.name - type type_name = Names.type_name - type global_name = Names.global_name - type fun_name = Names.fun_name (* TODO: this should a module we give to a functor! *) @@ -229,11 +226,8 @@ module IdOrderedType = struct type t = id let compare = compare_id - let to_string = show_id - let pp_t = pp_id - let show_t = show_id end @@ -452,13 +446,11 @@ let ctx_get (id : id) (ctx : extraction_ctx) : string = let ctx_get_global (id : A.GlobalDeclId.id) (ctx : extraction_ctx) : string = ctx_get (GlobalId id) ctx -let ctx_get_function (id : A.fun_id) - (rg : RegionGroupId.id option) +let ctx_get_function (id : A.fun_id) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = ctx_get (FunId (id, rg)) ctx -let ctx_get_local_function (id : A.FunDeclId.id) - (rg : RegionGroupId.id option) +let ctx_get_local_function (id : A.FunDeclId.id) (rg : RegionGroupId.id option) (ctx : extraction_ctx) : string = ctx_get_function (A.Regular id) rg ctx @@ -582,7 +574,7 @@ let ctx_add_decrases_clause (def : fun_decl) (ctx : extraction_ctx) : let name = ctx.fmt.decreases_clause_name def.def_id def.basename in ctx_add (DecreasesClauseId (A.Regular def.def_id)) name ctx -let ctx_add_global_decl_body (def : A.global_decl) (ctx : extraction_ctx) : +let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : extraction_ctx = let name = ctx.fmt.global_name def.name in let decl = GlobalId def.def_id in @@ -622,9 +614,8 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) ctx.fmt.fun_name def_id def.basename num_rgs rg_info (keep_fwd, num_backs) in (* Add the function name if it's not a global *) - if def.is_global_body - then ctx - else ctx_add (FunId (def_id, def.back_id)) name ctx + if def.is_global_decl_body then ctx + else ctx_add (FunId (def_id, def.back_id)) name ctx type names_map_init = { keywords : string list; @@ -690,11 +681,8 @@ let compute_type_decl_name (fmt : formatter) (def : type_decl) : string = information. TODO: move all those helpers. *) -let default_fun_suffix - (num_region_groups : int) - (rg : region_group_info option) - ((keep_fwd, num_backs) : bool * int) - : string = +let default_fun_suffix (num_region_groups : int) (rg : region_group_info option) + ((keep_fwd, num_backs) : bool * int) : string = (* There are several cases: - [rg] is `Some`: this is a forward function: - we add "_fwd" diff --git a/src/Substitute.ml b/src/Substitute.ml index 4b0a04ca..5a21e637 100644 --- a/src/Substitute.ml +++ b/src/Substitute.ml @@ -219,7 +219,7 @@ let operand_substitute (tsubst : T.TypeVarId.id -> T.ety) (op : E.operand) : | E.Move p -> E.Move (p_subst p) | E.Constant (ety, cv) -> let rsubst x = x in - E.Constant ( ty_substitute rsubst tsubst ety, cv ) + E.Constant (ty_substitute rsubst tsubst ety, cv) (** Apply a type substitution to an rvalue *) let rvalue_substitute (tsubst : T.TypeVarId.id -> T.ety) (rv : E.rvalue) : @@ -281,7 +281,9 @@ let rec statement_substitute (tsubst : T.TypeVarId.id -> T.ety) let p = place_substitute tsubst p in let rvalue = rvalue_substitute tsubst rvalue in A.Assign (p, rvalue) - | A.AssignGlobal g -> A.AssignGlobal g + | A.AssignGlobal g -> + (* Globals don't have type parameters *) + A.AssignGlobal g | A.FakeRead p -> let p = place_substitute tsubst p in A.FakeRead p diff --git a/src/SymbolicToPure.ml b/src/SymbolicToPure.ml index 81af6a8b..f321ce8c 100644 --- a/src/SymbolicToPure.ml +++ b/src/SymbolicToPure.ml @@ -72,9 +72,7 @@ type fun_context = { fun_infos : FA.fun_info A.FunDeclId.Map.t; } -type global_context = { - llbc_global_decls : A.global_decl A.GlobalDeclId.Map.t; -} +type global_context = { llbc_global_decls : A.global_decl A.GlobalDeclId.Map.t } type call_info = { forward : S.call; @@ -127,29 +125,31 @@ type bs_ctx = { let type_check_pattern (ctx : bs_ctx) (v : typed_pattern) : unit = let env = VarId.Map.empty in - let ctx = { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env - } in + let ctx = + { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env; + } + in let _ = PureTypeCheck.check_typed_pattern ctx v in () let type_check_texpression (ctx : bs_ctx) (e : texpression) : unit = let env = VarId.Map.empty in - let ctx = { - PureTypeCheck.type_decls = ctx.type_context.type_decls; - global_decls = ctx.global_context.llbc_global_decls; - env - } in + let ctx = + { + PureTypeCheck.type_decls = ctx.type_context.type_decls; + global_decls = ctx.global_context.llbc_global_decls; + env; + } + in PureTypeCheck.check_texpression ctx e (* TODO: move *) let bs_ctx_to_ast_formatter (ctx : bs_ctx) : Print.LlbcAst.ast_formatter = - Print.LlbcAst.fun_decl_to_ast_formatter - ctx.type_context.llbc_type_decls - ctx.fun_context.llbc_fun_decls - ctx.global_context.llbc_global_decls + Print.LlbcAst.fun_decl_to_ast_formatter ctx.type_context.llbc_type_decls + ctx.fun_context.llbc_fun_decls ctx.global_context.llbc_global_decls ctx.fun_decl let bs_ctx_to_pp_ast_formatter (ctx : bs_ctx) : PrintPure.ast_formatter = @@ -179,7 +179,9 @@ let fun_sig_to_string (ctx : bs_ctx) (sg : fun_sig) : string = let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in let global_decls = ctx.global_context.llbc_global_decls in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = @@ -187,7 +189,9 @@ let fun_decl_to_string (ctx : bs_ctx) (def : Pure.fun_decl) : string = let type_decls = ctx.type_context.llbc_type_decls in let fun_decls = ctx.fun_context.llbc_fun_decls in let global_decls = ctx.global_context.llbc_global_decls in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in PrintPure.fun_decl_to_string fmt def (* TODO: move *) @@ -214,8 +218,8 @@ let bs_ctx_lookup_llbc_type_decl (id : TypeDeclId.id) (ctx : bs_ctx) : T.type_decl = TypeDeclId.Map.find id ctx.type_context.llbc_type_decls -let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : A.fun_decl - = +let bs_ctx_lookup_llbc_fun_decl (id : A.FunDeclId.id) (ctx : bs_ctx) : + A.fun_decl = A.FunDeclId.Map.find id ctx.fun_context.llbc_fun_decls (* TODO: move *) @@ -1462,9 +1466,8 @@ and translate_end_abstraction (config : config) (abs : V.abs) (e : S.expression) given_back_inputs next_e and translate_global_eval (config : config) (gid : A.GlobalDeclId.id) - (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) - : texpression = - let (ctx, var) = fresh_var_for_symbolic_value sval ctx in + (sval : V.symbolic_value) (e : S.expression) (ctx : bs_ctx) : texpression = + let ctx, var = fresh_var_for_symbolic_value sval ctx in let decl = A.GlobalDeclId.Map.find gid ctx.global_context.llbc_global_decls in let global_expr = { id = Global gid; type_args = [] } in (* We use translate_fwd_ty to translate the global type *) @@ -1751,7 +1754,16 @@ let translate_fun_decl (config : config) (ctx : bs_ctx) Some { inputs; inputs_lvs; body } in (* Assemble the declaration *) - let def = { def_id; back_id = bid; basename; signature; is_global_body = def.is_global_body; body } in + let def = + { + def_id; + back_id = bid; + basename; + signature; + is_global_decl_body = def.is_global_decl_body; + body; + } + in (* Debugging *) log#ldebug (lazy diff --git a/src/Translate.ml b/src/Translate.ml index 25aff2b2..c9dc7943 100644 --- a/src/Translate.ml +++ b/src/Translate.ml @@ -64,9 +64,7 @@ let translate_function_to_symbolics (config : C.partial_config) ^ Print.fun_name_to_string fdef.A.name)); let { type_context; fun_context; global_context } = trans_ctx in - let fun_context = { - C.fun_decls = fun_context.fun_decls; - } in + let fun_context = { C.fun_decls = fun_context.fun_decls } in match fdef.body with | None -> None @@ -75,9 +73,8 @@ let translate_function_to_symbolics (config : C.partial_config) let synthesize = true in let evaluate gid = let inputs, symb = - evaluate_function_symbolic config synthesize - type_context fun_context global_context - fdef gid + evaluate_function_symbolic config synthesize type_context fun_context + global_context fdef gid in (inputs, Option.get symb) in @@ -102,8 +99,7 @@ let translate_function_to_symbolics (config : C.partial_config) let translate_function_to_pure (config : C.partial_config) (mp_config : Micro.config) (trans_ctx : trans_ctx) (fun_sigs : SymbolicToPure.fun_sig_named_outputs RegularFunIdMap.t) - (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) - (fdef : A.fun_decl) + (pure_type_decls : Pure.type_decl Pure.TypeDeclId.Map.t) (fdef : A.fun_decl) : pure_fun_translation = (* Debug *) log#ldebug @@ -144,9 +140,8 @@ let translate_function_to_pure (config : C.partial_config) fun_infos = fun_context.fun_infos; } in - let global_context = { - SymbolicToPure.llbc_global_decls = global_context.global_decls - } + let global_context = + { SymbolicToPure.llbc_global_decls = global_context.global_decls } in let ctx = { @@ -297,12 +292,14 @@ let translate_module_to_pure (config : C.partial_config) log#ldebug (lazy "translate_module_to_pure"); (* Compute the type and function contexts *) - let type_context, fun_context, global_context = compute_type_fun_contexts m in - let fun_infos = FA.analyze_module m fun_context.C.fun_decls global_context.C.global_decls use_state in - let fun_context = { - fun_decls = fun_context.fun_decls; - fun_infos; - } in + let type_context, fun_context, global_context = + compute_type_fun_global_contexts m + in + let fun_infos = + FA.analyze_module m fun_context.C.fun_decls global_context.C.global_decls + use_state + in + let fun_context = { fun_decls = fun_context.fun_decls; fun_infos } in let trans_ctx = { type_context; fun_context; global_context } in (* Translate all the type definitions *) @@ -498,8 +495,9 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) if ((not is_opaque) && config.extract_transparent) || (is_opaque && config.extract_opaque) - then ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif has_decr_clause def - ) + then + ExtractToFStar.extract_fun_decl ctx.extract_ctx fmt qualif + has_decr_clause def) fls); (* Insert unit tests if necessary *) if config.test_unit_functions then @@ -514,13 +512,18 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) let export_global (id : A.GlobalDeclId.id) : unit = let global_decls = ctx.extract_ctx.trans_ctx.global_context.global_decls in let global = A.GlobalDeclId.Map.find id global_decls in - let (_, (body, body_backs)) = A.FunDeclId.Map.find global.body_id ctx.trans_funs in + let _, (body, body_backs) = + A.FunDeclId.Map.find global.body_id ctx.trans_funs + in assert (List.length body_backs = 0); - + let is_opaque = Option.is_none body.Pure.body in - if ((not is_opaque) && config.extract_transparent) - || (is_opaque && config.extract_opaque) - then ExtractToFStar.extract_global_decl ctx.extract_ctx fmt global body config.interface + if + ((not is_opaque) && config.extract_transparent) + || (is_opaque && config.extract_opaque) + then + ExtractToFStar.extract_global_decl ctx.extract_ctx fmt global body + config.interface in let export_state_type () : unit = @@ -558,8 +561,7 @@ let extract_definitions (fmt : Format.formatter) (config : gen_config) in (* Translate *) export_functions true pure_funs - | Global id -> - export_global id + | Global id -> export_global id in (* If we need to export the state type: we try to export it after we defined @@ -677,8 +679,9 @@ let translate_module (filename : string) (dest_dir : string) (config : config) ctx trans_funs in - let ctx = List.fold_left - ExtractToFStar.extract_global_decl_register_names ctx m.globals + let ctx = + List.fold_left ExtractToFStar.extract_global_decl_register_names ctx + m.globals in (* Open the output file *) diff --git a/src/TypesUtils.ml b/src/TypesUtils.ml index 8088be7f..b5ea6fca 100644 --- a/src/TypesUtils.ml +++ b/src/TypesUtils.ml @@ -87,7 +87,6 @@ let rty_regions (ty : rty) : RegionId.Set.t = let obj = object inherit [_] iter_ty - method! visit_'r _env r = add_region r end in -- cgit v1.2.3 From 2b79c533d98f1bec8d332f660b36a05152b4c7dc Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 22 Sep 2022 18:13:56 +0200 Subject: Update PureMicroPasses.inline_useless_var_reassignments --- src/PureMicroPasses.ml | 67 +++++++++++++++++++++++++------------------------- src/PureUtils.ml | 6 +++++ 2 files changed, 39 insertions(+), 34 deletions(-) (limited to 'src') diff --git a/src/PureMicroPasses.ml b/src/PureMicroPasses.ml index 7927a068..c8ebfa6b 100644 --- a/src/PureMicroPasses.ml +++ b/src/PureMicroPasses.ml @@ -586,48 +586,47 @@ let inline_useless_var_reassignments (inline_named : bool) (inline_pure : bool) match (monadic, lv.value) with | false, PatVar (lv_var, _) -> (* We can filter if: *) - let filter = false in - (* 1. Either: - * - the left variable is unnamed or [inline_named] is true - * - the right-expression is a variable - *) - let filter = + (* 1. the left variable is unnamed or [inline_named] is true *) + let filter_left = match (inline_named, lv_var.basename) with - | true, _ | _, None -> is_var re - | _ -> filter + | true, _ | _, None -> true + | _ -> false + in + (* And either: + * 2.1 the right-expression is a variable or a global *) + let var_or_global = is_var re || is_global re in + (* Or: + * 2.2 the right-expression is a constant value, an ADT value, + * a projection or a primitive function call *and* the flag + * `inline_pure` is set *) + let pure_re = + is_const re + || + let app, _ = destruct_apps re in + match app.e with + | Qualif qualif -> ( + match qualif.id with + | AdtCons _ -> true (* ADT constructor *) + | Proj _ -> true (* Projector *) + | Func (Unop _ | Binop _) -> + true (* primitive function call *) + | Func (Regular _) -> false (* non-primitive function call *) + | _ -> false) + | _ -> false in - (* 2. Or: - * - the left variable is an unnamed variable - * - the right-expression is a value or a primitive function call - *) let filter = - if inline_pure then - let app, _ = destruct_apps re in - match app.e with - | Const _ | Var _ -> true (* constant or variable *) - | Qualif qualif -> ( - match qualif.id with - | AdtCons _ | Proj _ -> true (* ADT constructor *) - | Func (Unop _ | Binop _) -> - true (* primitive function call *) - | Func (Regular _) -> - false (* non-primitive function call *) - | Global _ -> - true (* Global constant or static *) - ) - | _ -> filter - else false + filter_left && (var_or_global || (inline_pure && pure_re)) in - (* Update the environment and continue the exploration *) + (* Update the rhs (we may perform substitutions inside, and it is + * better to do them *before* we inline it *) let re = self#visit_texpression env re in - (* TODO: once rvalues and expressions are merged, filter the - * let-binding (note that for now we leave it, expect it to - * become useless, and wait for a subsequent pass to filter it) *) - (* let env = add_subst lv_var.id re env in *) + (* Update the substitution environment *) let env = if filter then VarId.Map.add lv_var.id re env else env in + (* Update the next expression *) let e = self#visit_texpression env e in - Let (monadic, lv, re, e) + (* Reconstruct the `let`, only if the binding is not filtered *) + if filter then e.e else Let (monadic, lv, re, e) | _ -> super#visit_Let env monadic lv re e (** Visit the let-bindings to filter the useless ones (and update the substitution map while doing so *) diff --git a/src/PureUtils.ml b/src/PureUtils.ml index e72ff9d7..c3d4c983 100644 --- a/src/PureUtils.ml +++ b/src/PureUtils.ml @@ -173,6 +173,12 @@ let is_var (e : texpression) : bool = let as_var (e : texpression) : VarId.id = match e.e with Var v -> v | _ -> raise (Failure "Unreachable") +let is_global (e : texpression) : bool = + match e.e with Qualif { id = Global _; _ } -> true | _ -> false + +let is_const (e : texpression) : bool = + match e.e with Const _ -> true | _ -> false + (** Remove the external occurrences of [Meta] *) let rec unmeta (e : texpression) : texpression = match e.e with Meta (_, e) -> unmeta e | _ -> e -- cgit v1.2.3 From 65b7bcbb95d39e680cd7c579dd969dff9195eb5a Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 22 Sep 2022 18:24:40 +0200 Subject: Update the name registration for globals --- src/PureToExtract.ml | 7 ++++--- src/Translate.ml | 11 ++++++++--- 2 files changed, 12 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/PureToExtract.ml b/src/PureToExtract.ml index 255d4e1b..07a1732c 100644 --- a/src/PureToExtract.ml +++ b/src/PureToExtract.ml @@ -585,6 +585,9 @@ let ctx_add_global_decl_and_body (def : A.global_decl) (ctx : extraction_ctx) : let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) (def : fun_decl) (ctx : extraction_ctx) : extraction_ctx = + (* Sanity check: the function should not be a global body - those are handled + * separately *) + assert (not def.is_global_decl_body); (* Lookup the LLBC def to compute the region group information *) let def_id = def.def_id in let llbc_def = @@ -613,9 +616,7 @@ let ctx_add_fun_decl (trans_group : bool * pure_fun_translation) let name = ctx.fmt.fun_name def_id def.basename num_rgs rg_info (keep_fwd, num_backs) in - (* Add the function name if it's not a global *) - if def.is_global_decl_body then ctx - else ctx_add (FunId (def_id, def.back_id)) name ctx + ctx_add (FunId (def_id, def.back_id)) name ctx type names_map_init = { keywords : string list; diff --git a/src/Translate.ml b/src/Translate.ml index c9dc7943..61300ed8 100644 --- a/src/Translate.ml +++ b/src/Translate.ml @@ -670,12 +670,17 @@ let translate_module (filename : string) (dest_dir : string) (config : config) let ctx = List.fold_left (fun ctx (keep_fwd, def) -> - (* Note that we generate a decrease clause for all the recursive functions *) + (* We generate a decrease clause for all the recursive functions *) let gen_decr_clause = A.FunDeclId.Set.mem (fst def).Pure.def_id rec_functions in - ExtractToFStar.extract_fun_decl_register_names ctx keep_fwd - gen_decr_clause def) + (* Register the names, only if the function is not a global body - + * those are handled later *) + let is_global = (fst def).Pure.is_global_decl_body in + if is_global then ctx + else + ExtractToFStar.extract_fun_decl_register_names ctx keep_fwd + gen_decr_clause def) ctx trans_funs in -- cgit v1.2.3 From 34fed5feb6b768cdf1489936cc1529898bdcc4e9 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 22 Sep 2022 18:32:03 +0200 Subject: Add some comments --- src/ExtractToFStar.ml | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src') diff --git a/src/ExtractToFStar.ml b/src/ExtractToFStar.ml index ec0f88a4..b537e181 100644 --- a/src/ExtractToFStar.ml +++ b/src/ExtractToFStar.ml @@ -914,6 +914,9 @@ let rec extract_texpression (ctx : extraction_ctx) (fmt : F.formatter) | Switch (scrut, body) -> extract_Switch ctx fmt inside scrut body | Meta (_, e) -> extract_texpression ctx fmt inside e +(* Extract an application *or* a top-level qualif (function extraction has + * to handle top-level qualifiers, so it seemed more natural to merge the + * two cases) *) and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool) (app : texpression) (args : texpression list) : unit = (* We don't do the same thing if the app is a top-level identifier (function, -- cgit v1.2.3 From e1b9c968752946e36aeaed1f01272f8481b1a6f1 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 22 Sep 2022 18:40:08 +0200 Subject: Make minor cleanup --- src/PrintPure.ml | 28 ++++++++-------------------- src/Pure.ml | 6 ++++-- 2 files changed, 12 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/PrintPure.ml b/src/PrintPure.ml index 597330bf..0a7091f0 100644 --- a/src/PrintPure.ml +++ b/src/PrintPure.ml @@ -2,16 +2,6 @@ open Pure open PureUtils -module T = Types -module V = Values -module E = Expressions -module A = LlbcAst -module TypeDeclId = T.TypeDeclId -module TypeVarId = T.TypeVarId -module RegionId = T.RegionId -module VariantId = T.VariantId -module FieldId = T.FieldId -module SymbolicValueId = V.SymbolicValueId type type_formatter = { type_var_id_to_string : TypeVarId.id -> string; @@ -43,8 +33,8 @@ type ast_formatter = { adt_field_to_string : TypeDeclId.id -> VariantId.id option -> FieldId.id -> string option; adt_field_names : TypeDeclId.id -> VariantId.id option -> string list option; - fun_decl_id_to_string : A.FunDeclId.id -> string; - global_decl_id_to_string : A.GlobalDeclId.id -> string; + fun_decl_id_to_string : FunDeclId.id -> string; + global_decl_id_to_string : GlobalDeclId.id -> string; } let ast_to_value_formatter (fmt : ast_formatter) : value_formatter = @@ -86,12 +76,10 @@ let mk_type_formatter (type_decls : T.type_decl TypeDeclId.Map.t) functions (there is a difference between the forward/backward functions...) while we only need those definitions to lookup proper names for the def ids. *) -let mk_ast_formatter - (type_decls : T.type_decl TypeDeclId.Map.t) - (fun_decls : A.fun_decl A.FunDeclId.Map.t) - (global_decls : A.global_decl A.GlobalDeclId.Map.t) - (type_params : type_var list) : - ast_formatter = +let mk_ast_formatter (type_decls : T.type_decl TypeDeclId.Map.t) + (fun_decls : A.fun_decl FunDeclId.Map.t) + (global_decls : A.global_decl GlobalDeclId.Map.t) + (type_params : type_var list) : ast_formatter = let type_var_id_to_string vid = let var = T.TypeVarId.nth type_params vid in type_var_to_string var @@ -114,11 +102,11 @@ let mk_ast_formatter Print.LlbcAst.type_ctx_to_adt_field_to_string_fun type_decls in let fun_decl_id_to_string def_id = - let def = A.FunDeclId.Map.find def_id fun_decls in + let def = FunDeclId.Map.find def_id fun_decls in fun_name_to_string def.name in let global_decl_id_to_string def_id = - let def = A.GlobalDeclId.Map.find def_id global_decls in + let def = GlobalDeclId.Map.find def_id global_decls in global_name_to_string def.name in { diff --git a/src/Pure.ml b/src/Pure.ml index ced56c6a..afda2caa 100644 --- a/src/Pure.ml +++ b/src/Pure.ml @@ -10,6 +10,8 @@ module RegionGroupId = T.RegionGroupId module VariantId = T.VariantId module FieldId = T.FieldId module SymbolicValueId = V.SymbolicValueId +module FunDeclId = A.FunDeclId +module GlobalDeclId = A.GlobalDeclId module SynthPhaseId = IdGen () (** We give an identifier to every phase of the synthesis (forward, backward @@ -302,7 +304,7 @@ type projection = { adt_id : type_id; field_id : FieldId.id } [@@deriving show] type qualif_id = | Func of fun_id - | Global of A.GlobalDeclId.id + | Global of GlobalDeclId.id | AdtCons of adt_cons_id (** A function or ADT constructor identifier *) | Proj of projection (** Field projector *) [@@deriving show] @@ -566,7 +568,7 @@ type fun_body = { } type fun_decl = { - def_id : A.FunDeclId.id; + def_id : FunDeclId.id; back_id : T.RegionGroupId.id option; basename : fun_name; (** The "base" name of the function. -- cgit v1.2.3 From f68e3f3fd1858e638c571f140f149a1c4bee85f0 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 22 Sep 2022 18:41:16 +0200 Subject: Remove a useless file --- src/ExtractAst.ml | 57 ------------------------------------------------------- 1 file changed, 57 deletions(-) delete mode 100644 src/ExtractAst.ml (limited to 'src') diff --git a/src/ExtractAst.ml b/src/ExtractAst.ml deleted file mode 100644 index dd793291..00000000 --- a/src/ExtractAst.ml +++ /dev/null @@ -1,57 +0,0 @@ -(** This module defines the AST which is to be extracted to generate code. - This AST is voluntarily as simple as possible, so that the extraction - can focus on pretty-printing and on the syntax specific to the different - provers. - - TODO: we don't use this... - *) - -type constant_value = Pure.constant_value - -type pattern = - | PatVar of string - | PatDummy - | PatEnum of string * pattern list - (** Enum: the constructor name (tuple if `None`) and the fields. - Note that we never use structures as patters: we access the fields one - by one. - *) - | PatTuple of pattern list - -(** We want to keep terms a little bit structured, for pretty printing. - See the `FieldProj` and the `Record` cases, for instance. - *) -type term = - | Constant of constant_value - | Var of string - | FieldProj of term * term - (** `x.y` - - Of course, we can always use projectors like `record_get_y x`: - this variant is for pretty-printing. - - Note that `FieldProj` are generated when translating `place` from - the "pure" AST. - *) - | App of term * term - | Let of bool * pattern * term * term - | If of term * term * term - | Switch of term * (pattern * term) list - | Ascribed of term * term (** `x <: ty` *) - | Tuple of term list - | Record of (string * term) list - (** In case a record has named fields, we try to use them, to generate - code like: `{ x = 3; y = true; }` - Otherwise, we can use `App` (with the record constructor). - *) - -type fun_decl = { - name : string; - inputs : pattern list; - (** We can match over the inputs, hence the use of [pattern]. In practice, - we use [PatVar] and [PatDummy]. - *) - input_tys : term list; - output_ty : term; - body : term; -} -- cgit v1.2.3 From 4a8b4b1be044ffaa8de72cf847c00184b6b8ab40 Mon Sep 17 00:00:00 2001 From: Son Ho Date: Thu, 22 Sep 2022 18:45:25 +0200 Subject: Reformat the project with dune --- src/Assumed.ml | 7 +---- src/Collections.ml | 71 ------------------------------------------- src/Contexts.ml | 13 +++----- src/Errors.ml | 1 - src/Identifiers.ml | 32 ------------------- src/InterpreterBorrowsCore.ml | 5 --- src/InterpreterUtils.ml | 18 ++--------- src/Invariants.ml | 3 -- src/Names.ml | 4 --- src/Print.ml | 34 +++++++++++---------- src/PureTypeCheck.ml | 5 +-- src/Scalars.ml | 22 -------------- src/SynthesizeSymbolic.ml | 8 ++--- src/TranslateCore.ml | 10 ++++-- src/Types.ml | 17 ----------- src/Values.ml | 2 +- src/ValuesUtils.ml | 6 ---- src/dune | 34 ++++++++++++--------- 18 files changed, 58 insertions(+), 234 deletions(-) (limited to 'src') diff --git a/src/Assumed.ml b/src/Assumed.ml index b3128b9b..1e8bb669 100644 --- a/src/Assumed.ml +++ b/src/Assumed.ml @@ -38,13 +38,9 @@ module Sig = struct (** A few utilities *) let rvar_id_0 = T.RegionVarId.of_int 0 - let rvar_0 : T.RegionVarId.id T.region = T.Var rvar_id_0 - let rg_id_0 = T.RegionGroupId.of_int 0 - let tvar_id_0 = T.TypeVarId.of_int 0 - let tvar_0 : T.sty = T.TypeVar tvar_id_0 (** Region 'a of id 0 *) @@ -218,8 +214,7 @@ module Sig = struct let inputs = [ mk_ref_ty rvar_0 (mk_vec_ty tvar_0) is_mut (* &'a (mut) Vec *); - mk_usize_ty; - (* usize *) + mk_usize_ty (* usize *); ] in let output = mk_ref_ty rvar_0 tvar_0 is_mut (* &'a (mut) T *) in diff --git a/src/Collections.ml b/src/Collections.ml index 614857e6..2cb298a7 100644 --- a/src/Collections.ml +++ b/src/Collections.ml @@ -88,9 +88,7 @@ module type OrderedType = sig include Map.OrderedType val to_string : t -> string - val pp_t : Format.formatter -> t -> unit - val show_t : t -> string end @@ -99,9 +97,7 @@ module OrderedString : OrderedType with type t = string = struct include String let to_string s = s - let pp_t fmt s = Format.pp_print_string fmt s - let show_t s = s end @@ -109,7 +105,6 @@ module type Map = sig include Map.S val add_list : (key * 'a) list -> 'a t -> 'a t - val of_list : (key * 'a) list -> 'a t val to_string : string option -> ('a -> string) -> 'a t -> string @@ -123,7 +118,6 @@ module type Map = sig *) val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit - val show : ('a -> string) -> 'a t -> string end @@ -132,7 +126,6 @@ module MakeMap (Ord : OrderedType) : Map with type key = Ord.t = struct include Map let add_list bl m = List.fold_left (fun s (key, e) -> add key e s) m bl - let of_list bl = add_list bl empty let to_string indent_opt a_to_string m = @@ -177,7 +170,6 @@ module type Set = sig include Set.S val add_list : elt list -> t -> t - val of_list : elt list -> t val to_string : string option -> t -> string @@ -191,7 +183,6 @@ module type Set = sig *) val pp : Format.formatter -> t -> unit - val show : t -> string end @@ -200,7 +191,6 @@ module MakeSet (Ord : OrderedType) : Set with type elt = Ord.t = struct include Set let add_list bl s = List.fold_left (fun s e -> add e s) s bl - let of_list bl = add_list bl empty let to_string indent_opt m = @@ -239,79 +229,43 @@ end *) module type InjMap = sig type key - type elem - type t val empty : t - val is_empty : t -> bool - val mem : key -> t -> bool - val add : key -> elem -> t -> t - val singleton : key -> elem -> t - val remove : key -> t -> t - val compare : (elem -> elem -> int) -> t -> t -> int - val equal : (elem -> elem -> bool) -> t -> t -> bool - val iter : (key -> elem -> unit) -> t -> unit - val fold : (key -> elem -> 'b -> 'b) -> t -> 'b -> 'b - val for_all : (key -> elem -> bool) -> t -> bool - val exists : (key -> elem -> bool) -> t -> bool - val filter : (key -> elem -> bool) -> t -> t - val partition : (key -> elem -> bool) -> t -> t * t - val cardinal : t -> int - val bindings : t -> (key * elem) list - val min_binding : t -> key * elem - val min_binding_opt : t -> (key * elem) option - val max_binding : t -> key * elem - val max_binding_opt : t -> (key * elem) option - val choose : t -> key * elem - val choose_opt : t -> (key * elem) option - val split : key -> t -> t * elem option * t - val find : key -> t -> elem - val find_opt : key -> t -> elem option - val find_first : (key -> bool) -> t -> key * elem - val find_first_opt : (key -> bool) -> t -> (key * elem) option - val find_last : (key -> bool) -> t -> key * elem - val find_last_opt : (key -> bool) -> t -> (key * elem) option - val to_seq : t -> (key * elem) Seq.t - val to_seq_from : key -> t -> (key * elem) Seq.t - val add_seq : (key * elem) Seq.t -> t -> t - val of_seq : (key * elem) Seq.t -> t - val add_list : (key * elem) list -> t -> t - val of_list : (key * elem) list -> t end @@ -322,15 +276,11 @@ module MakeInjMap (Key : OrderedType) (Elem : OrderedType) : module Set = MakeSet (Elem) type key = Key.t - type elem = Elem.t - type t = { map : elem Map.t; elems : Set.t } let empty = { map = Map.empty; elems = Set.empty } - let is_empty m = Map.is_empty m.map - let mem k m = Map.mem k m.map let add k e m = @@ -345,15 +295,10 @@ module MakeInjMap (Key : OrderedType) (Elem : OrderedType) : | Some x -> { map = Map.remove k m.map; elems = Set.remove x m.elems } let compare f m1 m2 = Map.compare f m1.map m2.map - let equal f m1 m2 = Map.equal f m1.map m2.map - let iter f m = Map.iter f m.map - let fold f m x = Map.fold f m.map x - let for_all f m = Map.for_all f m.map - let exists f m = Map.exists f m.map (** Small helper *) @@ -381,19 +326,12 @@ module MakeInjMap (Key : OrderedType) (Elem : OrderedType) : (map_to_t map1, map_to_t map2) let cardinal m = Map.cardinal m.map - let bindings m = Map.bindings m.map - let min_binding m = Map.min_binding m.map - let min_binding_opt m = Map.min_binding_opt m.map - let max_binding m = Map.max_binding m.map - let max_binding_opt m = Map.max_binding_opt m.map - let choose m = Map.choose m.map - let choose_opt m = Map.choose_opt m.map let split k m = @@ -403,19 +341,12 @@ module MakeInjMap (Key : OrderedType) (Elem : OrderedType) : (l, data, r) let find k m = Map.find k m.map - let find_opt k m = Map.find_opt k m.map - let find_first k m = Map.find_first k m.map - let find_first_opt k m = Map.find_first_opt k m.map - let find_last k m = Map.find_last k m.map - let find_last_opt k m = Map.find_last_opt k m.map - let to_seq m = Map.to_seq m.map - let to_seq_from k m = Map.to_seq_from k m.map let rec add_seq s m = @@ -428,8 +359,6 @@ module MakeInjMap (Key : OrderedType) (Elem : OrderedType) : add_seq s m let of_seq s = add_seq s empty - let add_list ls m = List.fold_left (fun m (key, elem) -> add key elem m) m ls - let of_list ls = add_list ls empty end diff --git a/src/Contexts.ml b/src/Contexts.ml index 4f1e1506..716326cf 100644 --- a/src/Contexts.ml +++ b/src/Contexts.ml @@ -62,7 +62,6 @@ let symbolic_value_id_counter, fresh_symbolic_value_id = SymbolicValueId.fresh_stateful_generator () let borrow_id_counter, fresh_borrow_id = BorrowId.fresh_stateful_generator () - let region_id_counter, fresh_region_id = RegionId.fresh_stateful_generator () let abstraction_id_counter, fresh_abstraction_id = @@ -217,14 +216,9 @@ type type_context = { } [@@deriving show] -type fun_context = { - fun_decls : fun_decl FunDeclId.Map.t; -} -[@@deriving show] +type fun_context = { fun_decls : fun_decl FunDeclId.Map.t } [@@deriving show] -type global_context = { - global_decls : global_decl GlobalDeclId.Map.t; -} +type global_context = { global_decls : global_decl GlobalDeclId.Map.t } [@@deriving show] type eval_ctx = { @@ -265,7 +259,8 @@ let ctx_lookup_fun_decl (ctx : eval_ctx) (fid : FunDeclId.id) : fun_decl = FunDeclId.Map.find fid ctx.fun_context.fun_decls (** TODO: make this more efficient with maps *) -let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : global_decl = +let ctx_lookup_global_decl (ctx : eval_ctx) (gid : GlobalDeclId.id) : + global_decl = GlobalDeclId.Map.find gid ctx.global_context.global_decls (** Retrieve a variable's value in an environment *) diff --git a/src/Errors.ml b/src/Errors.ml index 69a030b1..31a53cf4 100644 --- a/src/Errors.ml +++ b/src/Errors.ml @@ -1,3 +1,2 @@ exception IntegerOverflow of unit - exception Unimplemented diff --git a/src/Identifiers.ml b/src/Identifiers.ml index 61238aac..9f6a863d 100644 --- a/src/Identifiers.ml +++ b/src/Identifiers.ml @@ -13,15 +13,10 @@ module type Id = sig (** Id generator - simply a counter *) val zero : id - val generator_zero : generator - val generator_from_incr_id : id -> generator - val fresh_stateful_generator : unit -> generator ref * (unit -> id) - val mk_stateful_generator : generator -> generator ref * (unit -> id) - val incr : id -> id (* TODO: this should be stateful! - but we may want to be able to duplicate @@ -30,29 +25,17 @@ module type Id = sig TODO: change the order of the returned types *) val fresh : generator -> id * generator - val to_string : id -> string - val pp_id : Format.formatter -> id -> unit - val show_id : id -> string - val id_of_json : Yojson.Basic.t -> (id, string) result - val compare_id : id -> id -> int - val max : id -> id -> id - val min : id -> id -> id - val pp_generator : Format.formatter -> generator -> unit - val show_generator : generator -> string - val to_int : id -> int - val of_int : int -> id - val nth : 'a list -> id -> 'a (* TODO: change the signature (invert the index and the list *) @@ -75,9 +58,7 @@ module type Id = sig val iteri : (id -> 'a -> unit) -> 'a list -> unit module Ord : C.OrderedType with type t = id - module Set : C.Set with type elt = id - module Map : C.Map with type key = id end @@ -88,11 +69,9 @@ end module IdGen () : Id = struct (* TODO: use Z.t *) type id = int [@@deriving show] - type generator = id [@@deriving show] let zero = 0 - let generator_zero = 0 let incr x = @@ -113,13 +92,9 @@ module IdGen () : Id = struct (g, fresh) let fresh_stateful_generator () = mk_stateful_generator 0 - let fresh gen = (gen, incr gen) - let to_string = string_of_int - let to_int x = x - let of_int x = x let id_of_json js = @@ -129,13 +104,9 @@ module IdGen () : Id = struct | _ -> Error ("id_of_json: failed on " ^ Yojson.Basic.show js) let compare_id = compare - let max id0 id1 = if id0 > id1 then id0 else id1 - let min id0 id1 = if id0 < id1 then id0 else id1 - let nth v id = List.nth v id - let nth_opt v id = List.nth_opt v id let rec update_nth vec id v = @@ -158,11 +129,8 @@ module IdGen () : Id = struct type t = id let compare = compare - let to_string = to_string - let pp_t = pp_id - let show_t = show_id end diff --git a/src/InterpreterBorrowsCore.ml b/src/InterpreterBorrowsCore.ml index d47989c3..f2f10944 100644 --- a/src/InterpreterBorrowsCore.ml +++ b/src/InterpreterBorrowsCore.ml @@ -582,7 +582,6 @@ let get_first_loan_in_value (v : V.typed_value) : V.loan_content option = let obj = object inherit [_] V.iter_typed_value - method! visit_loan_content _ lc = raise (FoundLoanContent lc) end in @@ -597,7 +596,6 @@ let get_first_borrow_in_value (v : V.typed_value) : V.borrow_content option = let obj = object inherit [_] V.iter_typed_value - method! visit_borrow_content _ bc = raise (FoundBorrowContent bc) end in @@ -700,7 +698,6 @@ let lookup_intersecting_aproj_borrows_opt (lookup_shared : bool) let obj = object inherit [_] C.iter_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_abstract_shared_borrows abs asb = @@ -791,7 +788,6 @@ let update_intersecting_aproj_borrows (can_update_shared : bool) let obj = object inherit [_] C.map_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_abstract_shared_borrows abs asb = @@ -920,7 +916,6 @@ let update_intersecting_aproj_loans (proj_regions : T.RegionId.Set.t) let obj = object inherit [_] C.map_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_aproj abs sproj = diff --git a/src/InterpreterUtils.ml b/src/InterpreterUtils.ml index 6ef66f1d..fed5ff9b 100644 --- a/src/InterpreterUtils.ml +++ b/src/InterpreterUtils.ml @@ -12,33 +12,19 @@ module PA = Print.EvalCtxLlbcAst (** Some utilities *) let eval_ctx_to_string = Print.Contexts.eval_ctx_to_string - let ety_to_string = PA.ety_to_string - let rty_to_string = PA.rty_to_string - let symbolic_value_to_string = PA.symbolic_value_to_string - let borrow_content_to_string = PA.borrow_content_to_string - let loan_content_to_string = PA.loan_content_to_string - let aborrow_content_to_string = PA.aborrow_content_to_string - let aloan_content_to_string = PA.aloan_content_to_string - let aproj_to_string = PA.aproj_to_string - let typed_value_to_string = PA.typed_value_to_string - let typed_avalue_to_string = PA.typed_avalue_to_string - let place_to_string = PA.place_to_string - let operand_to_string = PA.operand_to_string - let statement_to_string ctx = PA.statement_to_string ctx "" " " - let statement_to_string_with_tab ctx = PA.statement_to_string ctx " " " " let same_symbolic_id (sv0 : V.symbolic_value) (sv1 : V.symbolic_value) : bool = @@ -211,7 +197,6 @@ let bottom_in_value (ended_regions : T.RegionId.Set.t) (v : V.typed_value) : let obj = object inherit [_] V.iter_typed_value - method! visit_Bottom _ = raise Found method! visit_symbolic_value _ s = @@ -238,7 +223,8 @@ let value_has_ret_symbolic_value_with_borrow_under_mut (ctx : C.eval_ctx) raise Found else () | V.SynthInput | V.SynthInputGivenBack | V.FunCallGivenBack - | V.SynthRetGivenBack -> () + | V.SynthRetGivenBack -> + () | V.Global -> () end in diff --git a/src/Invariants.ml b/src/Invariants.ml index 81e35de3..ef255010 100644 --- a/src/Invariants.ml +++ b/src/Invariants.ml @@ -399,7 +399,6 @@ let check_typing_invariant (ctx : C.eval_ctx) : unit = let visitor = object inherit [_] C.iter_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs method! visit_typed_value info tv = @@ -705,9 +704,7 @@ let check_symbolic_values (_config : C.config) (ctx : C.eval_ctx) : unit = let obj = object inherit [_] C.iter_eval_ctx as super - method! visit_abs _ abs = super#visit_abs (Some abs) abs - method! visit_Symbolic _ sv = add_env_sv sv method! visit_abstract_shared_borrows abs asb = diff --git a/src/Names.ml b/src/Names.ml index 0db5291a..209f8547 100644 --- a/src/Names.ml +++ b/src/Names.ml @@ -1,5 +1,4 @@ open Identifiers - module Disambiguator = IdGen () (** See the comments for [Name] *) @@ -49,11 +48,8 @@ type name = path_elem list [@@deriving show, ord] let to_name (ls : string list) : name = List.map (fun s -> Ident s) ls type module_name = name [@@deriving show, ord] - type type_name = name [@@deriving show, ord] - type fun_name = name [@@deriving show, ord] - type global_name = name [@@deriving show, ord] (** Filter the disambiguators equal to 0 in a name *) diff --git a/src/Print.ml b/src/Print.ml index 6b11a3ff..c10c5989 100644 --- a/src/Print.ml +++ b/src/Print.ml @@ -761,11 +761,9 @@ module LlbcAst = struct global_decl_id_to_string; } - let fun_decl_to_ast_formatter - (type_decls : T.type_decl T.TypeDeclId.Map.t) + let fun_decl_to_ast_formatter (type_decls : T.type_decl T.TypeDeclId.Map.t) (fun_decls : A.fun_decl A.FunDeclId.Map.t) - (global_decls : A.global_decl A.GlobalDeclId.Map.t) - (fdef : A.fun_decl) : + (global_decls : A.global_decl A.GlobalDeclId.Map.t) (fdef : A.fun_decl) : ast_formatter = let rvar_to_string r = let rvar = T.RegionVarId.nth fdef.signature.region_params r in @@ -942,7 +940,8 @@ module LlbcAst = struct | A.Assign (p, rv) -> indent ^ place_to_string fmt p ^ " := " ^ rvalue_to_string fmt rv | A.AssignGlobal { dst; global } -> - indent ^ fmt.var_id_to_string dst ^ " := global " ^ fmt.global_decl_id_to_string global + indent ^ fmt.var_id_to_string dst ^ " := global " + ^ fmt.global_decl_id_to_string global | A.FakeRead p -> indent ^ "fake_read " ^ place_to_string fmt p | A.SetDiscriminant (p, variant_id) -> (* TODO: improve this to lookup the variant name by using the def id *) @@ -1132,11 +1131,9 @@ module Module = struct (** Generate an [ast_formatter] by using a definition context in combination with the variables local to a function's definition *) - let def_ctx_to_ast_formatter - (type_context : T.type_decl T.TypeDeclId.Map.t) + let def_ctx_to_ast_formatter (type_context : T.type_decl T.TypeDeclId.Map.t) (fun_context : A.fun_decl A.FunDeclId.Map.t) - (global_context : A.global_decl A.GlobalDeclId.Map.t) - (def : A.fun_decl) : + (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : PA.ast_formatter = let rvar_to_string vid = let var = T.RegionVarId.nth def.signature.region_params vid in @@ -1188,23 +1185,28 @@ module Module = struct (** This function pretty-prints a function definition by using a definition context *) - let fun_decl_to_string - (type_context : T.type_decl T.TypeDeclId.Map.t) + let fun_decl_to_string (type_context : T.type_decl T.TypeDeclId.Map.t) (fun_context : A.fun_decl A.FunDeclId.Map.t) - (global_context : A.global_decl A.GlobalDeclId.Map.t) - (def : A.fun_decl) : string = - let fmt = def_ctx_to_ast_formatter type_context fun_context global_context def in + (global_context : A.global_decl A.GlobalDeclId.Map.t) (def : A.fun_decl) : + string = + let fmt = + def_ctx_to_ast_formatter type_context fun_context global_context def + in PA.fun_decl_to_string fmt "" " " def let module_to_string (m : M.llbc_module) : string = - let types_defs_map, funs_defs_map, globals_defs_map = M.compute_defs_maps m in + let types_defs_map, funs_defs_map, globals_defs_map = + M.compute_defs_maps m + in (* The types *) let type_decls = List.map (type_decl_to_string types_defs_map) m.M.types in (* The functions *) let fun_decls = - List.map (fun_decl_to_string types_defs_map funs_defs_map globals_defs_map) m.M.functions + List.map + (fun_decl_to_string types_defs_map funs_defs_map globals_defs_map) + m.M.functions in (* Put everything together *) diff --git a/src/PureTypeCheck.ml b/src/PureTypeCheck.ml index 39fb5073..5aefb0be 100644 --- a/src/PureTypeCheck.ml +++ b/src/PureTypeCheck.ml @@ -40,7 +40,8 @@ let get_adt_field_types (type_decls : type_decl TypeDeclId.Map.t) type tc_ctx = { type_decls : type_decl TypeDeclId.Map.t; (** The type declarations *) - global_decls : A.global_decl A.GlobalDeclId.Map.t; (** The global declarations *) + global_decls : A.global_decl A.GlobalDeclId.Map.t; + (** The global declarations *) env : ty VarId.Map.t; (** Environment from variables to types *) } @@ -112,7 +113,7 @@ let rec check_texpression (ctx : tc_ctx) (e : texpression) : unit = check_texpression ctx body | Qualif qualif -> ( match qualif.id with - | Func _ -> () (* TODO *) + | Func _ -> () (* TODO *) | Global _ -> () (* TODO *) | Proj { adt_id = proj_adt_id; field_id } -> (* Note we can only project fields of structures (not enumerations) *) diff --git a/src/Scalars.ml b/src/Scalars.ml index 3324c24b..03ca506c 100644 --- a/src/Scalars.ml +++ b/src/Scalars.ml @@ -4,43 +4,24 @@ open Values (** The minimum/maximum values an integer type can have depending on its type *) let i8_min = Z.of_string "-128" - let i8_max = Z.of_string "127" - let i16_min = Z.of_string "-32768" - let i16_max = Z.of_string "32767" - let i32_min = Z.of_string "-2147483648" - let i32_max = Z.of_string "2147483647" - let i64_min = Z.of_string "-9223372036854775808" - let i64_max = Z.of_string "9223372036854775807" - let i128_min = Z.of_string "-170141183460469231731687303715884105728" - let i128_max = Z.of_string "170141183460469231731687303715884105727" - let u8_min = Z.of_string "0" - let u8_max = Z.of_string "255" - let u16_min = Z.of_string "0" - let u16_max = Z.of_string "65535" - let u32_min = Z.of_string "0" - let u32_max = Z.of_string "4294967295" - let u64_min = Z.of_string "0" - let u64_max = Z.of_string "18446744073709551615" - let u128_min = Z.of_string "0" - let u128_max = Z.of_string "340282366920938463463374607431768211455" (** Being a bit conservative about isize/usize: depending on the system, @@ -48,11 +29,8 @@ let u128_max = Z.of_string "340282366920938463463374607431768211455" want to take that into account in the future *) let isize_min = i32_min - let isize_max = i32_max - let usize_min = u32_min - let usize_max = u32_max (** Check that an integer value is in range *) diff --git a/src/SynthesizeSymbolic.ml b/src/SynthesizeSymbolic.ml index fa244649..a2256bdd 100644 --- a/src/SynthesizeSymbolic.ml +++ b/src/SynthesizeSymbolic.ml @@ -114,11 +114,9 @@ let synthesize_function_call (call_id : call_id) in Some (FunCall (call, expr)) -let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) (expr : expression option) - : expression option = - match expr with - | None -> None - | Some e -> Some (EvalGlobal (gid, dest, e)) +let synthesize_global_eval (gid : A.GlobalDeclId.id) (dest : V.symbolic_value) + (expr : expression option) : expression option = + match expr with None -> None | Some e -> Some (EvalGlobal (gid, dest, e)) let synthesize_regular_function_call (fun_id : A.fun_id) (call_id : V.FunCallId.id) (abstractions : V.AbstractionId.id list) diff --git a/src/TranslateCore.ml b/src/TranslateCore.ml index e77445cd..326bb05f 100644 --- a/src/TranslateCore.ml +++ b/src/TranslateCore.ml @@ -24,7 +24,7 @@ type global_context = C.global_context [@@deriving show] type trans_ctx = { type_context : type_context; fun_context : fun_context; - global_context : global_context + global_context : global_context; } type pure_fun_translation = Pure.fun_decl * Pure.fun_decl list @@ -46,7 +46,9 @@ let fun_sig_to_string (ctx : trans_ctx) (sg : Pure.fun_sig) : string = let type_decls = ctx.type_context.type_decls in let fun_decls = ctx.fun_context.fun_decls in let global_decls = ctx.global_context.global_decls in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in PrintPure.fun_sig_to_string fmt sg let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = @@ -54,7 +56,9 @@ let fun_decl_to_string (ctx : trans_ctx) (def : Pure.fun_decl) : string = let type_decls = ctx.type_context.type_decls in let fun_decls = ctx.fun_context.fun_decls in let global_decls = ctx.global_context.global_decls in - let fmt = PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params in + let fmt = + PrintPure.mk_ast_formatter type_decls fun_decls global_decls type_params + in PrintPure.fun_decl_to_string fmt def let fun_decl_id_to_string (ctx : trans_ctx) (id : A.FunDeclId.id) : string = diff --git a/src/Types.ml b/src/Types.ml index 5ff407c9..5bd172cb 100644 --- a/src/Types.ml +++ b/src/Types.ml @@ -1,12 +1,8 @@ open Identifiers open Names - module TypeVarId = IdGen () - module TypeDeclId = IdGen () - module VariantId = IdGen () - module FieldId = IdGen () module RegionVarId = IdGen () @@ -24,7 +20,6 @@ type ('id, 'name) indexed_var = { [@@deriving show] type type_var = (TypeVarId.id, string) indexed_var [@@deriving show] - type region_var = (RegionVarId.id, string option) indexed_var [@@deriving show] (** A region. @@ -82,13 +77,10 @@ type integer_type = [@@deriving show, ord] let all_signed_int_types = [ Isize; I8; I16; I32; I64; I128 ] - let all_unsigned_int_types = [ Usize; U8; U16; U32; U64; U128 ] - let all_int_types = List.append all_signed_int_types all_unsigned_int_types type ref_kind = Mut | Shared [@@deriving show, ord] - type assumed_ty = Box | Vec | Option [@@deriving show, ord] (** The variant id for `Option::None` *) @@ -109,15 +101,10 @@ type type_id = AdtId of TypeDeclId.id | Tuple | Assumed of assumed_ty class ['self] iter_ty_base = object (_self : 'self) inherit [_] VisitorsRuntime.iter - method visit_'r : 'env -> 'r -> unit = fun _ _ -> () - method visit_id : 'env -> TypeVarId.id -> unit = fun _ _ -> () - method visit_type_id : 'env -> type_id -> unit = fun _ _ -> () - method visit_integer_type : 'env -> integer_type -> unit = fun _ _ -> () - method visit_ref_kind : 'env -> ref_kind -> unit = fun _ _ -> () end @@ -125,11 +112,8 @@ class ['self] iter_ty_base = class ['self] map_ty_base = object (_self : 'self) inherit [_] VisitorsRuntime.map - method visit_'r : 'env -> 'r -> 'r = fun _ r -> r - method visit_id : 'env -> TypeVarId.id -> TypeVarId.id = fun _ id -> id - method visit_type_id : 'env -> type_id -> type_id = fun _ id -> id method visit_integer_type : 'env -> integer_type -> integer_type = @@ -196,7 +180,6 @@ type ety = erased_region ty [@@deriving show, ord] *) type field = { field_name : string option; field_ty : sty } [@@deriving show] - type variant = { variant_name : string; fields : field list } [@@deriving show] type type_decl_kind = diff --git a/src/Values.ml b/src/Values.ml index 13cd2580..fb927fb5 100644 --- a/src/Values.ml +++ b/src/Values.ml @@ -65,7 +65,7 @@ type sv_kind = *) | SynthInputGivenBack (** The value was given back upon ending one of the input abstractions *) - | Global (** The value is a global *) + | Global (** The value is a global *) [@@deriving show] type symbolic_value = { diff --git a/src/ValuesUtils.ml b/src/ValuesUtils.ml index 2814615c..bc205622 100644 --- a/src/ValuesUtils.ml +++ b/src/ValuesUtils.ml @@ -11,7 +11,6 @@ let mk_unit_value : typed_value = { value = Adt { variant_id = None; field_values = [] }; ty = mk_unit_ty } let mk_typed_value (ty : ety) (value : value) : typed_value = { value; ty } - let mk_bottom (ty : ety) : typed_value = { value = Bottom; ty } (** Box a value *) @@ -38,7 +37,6 @@ let borrows_in_value (v : typed_value) : bool = let obj = object inherit [_] iter_typed_value - method! visit_borrow_content _env _ = raise Found end in @@ -53,7 +51,6 @@ let inactivated_in_value (v : typed_value) : bool = let obj = object inherit [_] iter_typed_value - method! visit_InactivatedMutBorrow _env _ = raise Found end in @@ -68,7 +65,6 @@ let loans_in_value (v : typed_value) : bool = let obj = object inherit [_] iter_typed_value - method! visit_loan_content _env _ = raise Found end in @@ -84,9 +80,7 @@ let outer_loans_in_value (v : typed_value) : bool = let obj = object inherit [_] iter_typed_value - method! visit_loan_content _env _ = raise Found - method! visit_borrow_content _ _ = () end in diff --git a/src/dune b/src/dune index ba6c076b..ccf726c9 100644 --- a/src/dune +++ b/src/dune @@ -1,21 +1,25 @@ ;; core: for Core.Unix.mkdir_p + (executable (name main) - (preprocess (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) + (preprocess + (pps ppx_deriving.show ppx_deriving.ord visitors.ppx)) (libraries ppx_deriving yojson zarith easy_logging core_unix)) (env - (dev (flags - :standard - -safe-string - -g - ;-dsource - -warn-error -5-8-9-11-14-33-20-21-26-27-39 - )) - (release (flags - :standard - -safe-string - -g - ;-dsource - -warn-error -5-8-9-11-14-33-20-21-26-27-39 - ))) + (dev + (flags + :standard + -safe-string + -g + ;-dsource + -warn-error + -5-8-9-11-14-33-20-21-26-27-39)) + (release + (flags + :standard + -safe-string + -g + ;-dsource + -warn-error + -5-8-9-11-14-33-20-21-26-27-39))) -- cgit v1.2.3