diff --git a/charon-ml/src/CharonVersion.ml b/charon-ml/src/CharonVersion.ml index 2fe366e4a..40252af44 100644 --- a/charon-ml/src/CharonVersion.ml +++ b/charon-ml/src/CharonVersion.ml @@ -1,3 +1,3 @@ (* This is an automatically generated file, generated from `charon/Cargo.toml`. *) (* To re-generate this file, rune `make` in the root directory *) -let supported_charon_version = "0.1.183" +let supported_charon_version = "0.1.184" diff --git a/charon-ml/src/GAst.ml b/charon-ml/src/GAst.ml index 2d4cca5c8..4ee6b904d 100644 --- a/charon-ml/src/GAst.ml +++ b/charon-ml/src/GAst.ml @@ -4,6 +4,7 @@ open Types open Meta open Expressions include Generated_GAst +include Generated_FullAst (* FIXME(#287): Avoid derives triggering deprecation warnings *) [@@@alert "-deprecated"] @@ -26,43 +27,16 @@ type trait_declaration_group = TraitDeclId.id g_declaration_group type trait_impl_group = TraitImplId.id g_declaration_group [@@deriving show] type mixed_declaration_group = item_id g_declaration_group [@@deriving show] -(* Hand-written because the rust equivalent isn't generic *) -type 'body body = - | Body of 'body gexpr_body - | TraitMethodWithoutDefault - | Extern of string - | Intrinsic of { name : string; arg_names : string list } - | TargetDispatch of (string * fun_decl_ref) list - | Opaque - | Missing - | Error of error -[@@deriving show] - -(* Hand-written because the rust equivalent isn't generic *) -type 'body gfun_decl = { - def_id : FunDeclId.id; - item_meta : item_meta; - generics : generic_params; - signature : fun_sig; - src : item_source; - is_global_initializer : GlobalDeclId.id option; - body : 'body body; -} -[@@deriving show] - -type target_info = { target_pointer_size : int; is_little_endian : bool } -[@@deriving show] - (* Hand-written because the rust equivalent isn't generic *) (** A crate *) -type 'fun_body gcrate = { +type crate = { name : string; options : cli_options; target_information : (string * target_info) list; declarations : declaration_group list; type_decls : type_decl TypeDeclId.Map.t; - fun_decls : 'fun_body gfun_decl FunDeclId.Map.t; + fun_decls : fun_decl FunDeclId.Map.t; global_decls : global_decl GlobalDeclId.Map.t; trait_decls : trait_decl TraitDeclId.Map.t; trait_impls : trait_impl TraitImplId.Map.t; diff --git a/charon-ml/src/GAstOfJson.ml b/charon-ml/src/GAstOfJson.ml deleted file mode 100644 index da8e3bf79..000000000 --- a/charon-ml/src/GAstOfJson.ml +++ /dev/null @@ -1,190 +0,0 @@ -(** Functions to load (U)LLBC ASTs from json. - - Initially, we used [ppx_derive_yojson] to automate this. However, - [ppx_derive_yojson] expects formatting to be slightly different from what - [serde_rs] generates (because it uses [Yojson.Safe.t] and not - [Yojson.Basic.t]). *) - -open Yojson.Basic -open OfJsonBasic -open Identifiers -open Meta -open Values -open Types -open Scalars -open Expressions -open GAst -include Generated_GAstOfJson - -let option_list_of_json of_json = list_of_json (option_of_json of_json) - -(* This is written by hand because the corresponding rust type is not type-generic. *) -let rec gfun_decl_of_json - (body_of_json : of_json_ctx -> json -> ('body body, string) result) - (ctx : of_json_ctx) (js : json) : ('body gfun_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("item_meta", item_meta); - ("generics", generics); - ("signature", signature); - ("src", src); - ("is_global_initializer", is_global_initializer); - ("body", body); - ] -> - let* def_id = FunDeclId.id_of_json ctx def_id in - let* item_meta = item_meta_of_json ctx item_meta in - let* generics = generic_params_of_json ctx generics in - let* signature = fun_sig_of_json ctx signature in - let* src = item_source_of_json ctx src in - let* is_global_initializer = - option_of_json global_decl_id_of_json ctx is_global_initializer - in - let* body = body_of_json ctx body in - Ok - { - def_id; - item_meta; - generics; - signature; - src; - is_global_initializer; - body; - } - | _ -> Error "") - -(** Deserialize a map from file id to file name. - - In the serialized LLBC, the files in the loc spans are refered to by their - ids, in order to save space. In a functional language like OCaml this is not - necessary: we thus replace the file ids by the file name themselves in the - AST. The "id to file" map is thus only used in the deserialization process. -*) -and id_to_file_of_json (ctx : of_json_ctx) (js : json) : - (of_json_ctx, string) result = - combine_error_msgs js __FUNCTION__ - ((* The map is stored as a list of pairs (key, value): we deserialize - * this list then convert it to a map *) - let* files = list_of_json (option_of_json file_of_json) ctx js in - let files_with_ids = - List.filter_map - (fun (i, file) -> - match file with - | None -> None - | Some file -> Some (i, file)) - (List.mapi (fun i file -> (FileId.of_int i, file)) files) - in - let id_to_file_map = FileId.Map.of_list files_with_ids in - Ok { ctx with id_to_file_map }) - -(* This is written by hand because the corresponding rust type is not - type-generic. Note: because of hash-cons deduplication, we must make sure to - deserialize in the exact same order as the rust side. *) -and gtranslated_crate_of_json - (body_of_json : of_json_ctx -> json -> ('body body, string) result) - (js : json) : ('body gcrate, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("crate_name", crate_name); - ("options", options); - ("target_information", target_info); - ("item_names", item_names); - ("short_names", short_names); - ("files", files); - ("type_decls", type_decls); - ("fun_decls", fun_decls); - ("global_decls", global_decls); - ("trait_decls", trait_decls); - ("trait_impls", trait_impls); - ("unit_metadata", unit_metadata); - ("ordered_decls", ordered_decls); - ] -> - let ctx = empty_of_json_ctx in - - (* This can be deserialized out of order because it contains no hash-consed values *) - let* ctx = id_to_file_of_json ctx files in - - let* crate_name = string_of_json ctx crate_name in - let* options = cli_options_of_json ctx options in - let* target_information = - list_of_json - (key_value_pair_of_json string_of_json target_info_of_json) - ctx target_info - in - let* _item_names = - list_of_json - (key_value_pair_of_json item_id_of_json name_of_json) - ctx item_names - in - let* _short_names = - list_of_json - (key_value_pair_of_json item_id_of_json name_of_json) - ctx short_names - in - let* type_decls = - option_list_of_json type_decl_of_json ctx type_decls - in - let* fun_decls = - option_list_of_json (gfun_decl_of_json body_of_json) ctx fun_decls - in - let* global_decls = - option_list_of_json global_decl_of_json ctx global_decls - in - let* trait_decls = - option_list_of_json trait_decl_of_json ctx trait_decls - in - let* trait_impls = - option_list_of_json trait_impl_of_json ctx trait_impls - in - let* unit_metadata = global_decl_ref_of_json ctx unit_metadata in - let* ordered_decls = - option_of_json - (list_of_json declaration_group_of_json) - ctx ordered_decls - in - - let type_decls = TypeDeclId.map_of_indexed_list type_decls in - let fun_decls = FunDeclId.map_of_indexed_list fun_decls in - let global_decls = GlobalDeclId.map_of_indexed_list global_decls in - let trait_decls = TraitDeclId.map_of_indexed_list trait_decls in - let trait_impls = TraitImplId.map_of_indexed_list trait_impls in - let ordered_decls = Option.value ordered_decls ~default:[] in - - Ok - { - name = crate_name; - options; - target_information; - declarations = ordered_decls; - type_decls; - fun_decls; - global_decls; - trait_decls; - trait_impls; - unit_metadata; - } - | _ -> Error "") - -and gcrate_of_json - (body_of_json : of_json_ctx -> json -> ('body body, string) result) - (js : json) : ('body gcrate, string) result = - match js with - | `Assoc [ ("charon_version", charon_version); ("translated", translated) ] - | `Assoc [ ("charon_version", charon_version); ("translated", translated); _ ] - -> - (* Ensure the version is the one we support. *) - let* charon_version = string_of_json () charon_version in - if - not (String.equal charon_version CharonVersion.supported_charon_version) - then - Error - ("Incompatible version of charon: this program supports llbc emitted \ - by charon v" ^ CharonVersion.supported_charon_version - ^ " but attempted to read a file emitted by charon v" ^ charon_version - ^ ".") - else gtranslated_crate_of_json body_of_json translated - | _ -> combine_error_msgs js __FUNCTION__ (Error "") diff --git a/charon-ml/src/GAstUtils.ml b/charon-ml/src/GAstUtils.ml index 39d760f7d..85e63ebd9 100644 --- a/charon-ml/src/GAstUtils.ml +++ b/charon-ml/src/GAstUtils.ml @@ -50,7 +50,7 @@ let fun_body_get_input_vars (fbody : 'body gexpr_body) : local list = (** Get the signature of this function as a bound value, i.e. including its generics parameters. *) -let bound_fun_sig_of_decl (def : 'a gfun_decl) : bound_fun_sig = +let bound_fun_sig_of_decl (def : fun_decl) : bound_fun_sig = { item_binder_params = def.generics; item_binder_value = def.signature } (** Lookup a method in this trait decl. The two levels of binders in the output @@ -112,6 +112,32 @@ let declaration_group_to_list (g : declaration_group) : item_id list = List.map (fun id -> IdTraitImpl id) (g_declaration_group_to_list g) | MixedGroup g -> g_declaration_group_to_list g +let body_as_structured : body -> LlbcAst.expr_body option = function + | StructuredBody body -> Some body + | _ -> None + +let body_as_structured_exn : body -> LlbcAst.expr_body = function + | StructuredBody body -> body + | _ -> failwith "Expected a structured body" + +let body_as_unstructured : body -> UllbcAst.expr_body option = function + | UnstructuredBody body -> Some body + | _ -> None + +let body_as_unstructured_exn : body -> UllbcAst.expr_body = function + | UnstructuredBody body -> body + | _ -> failwith "Expected an unstructured body" + +let has_body : body -> bool = function + | StructuredBody _ | UnstructuredBody _ -> true + | IntrinsicBody _ + | ExternBody _ + | OpaqueBody + | TraitMethodWithoutDefaultBody + | TargetDispatchBody _ + | MissingBody + | ErrorBody _ -> false + (** Split a module's declarations between types, functions and globals *) let split_declarations (decls : declaration_group list) : type_declaration_group list diff --git a/charon-ml/src/LlbcAst.ml b/charon-ml/src/LlbcAst.ml index 2a068a36f..a3c5233fb 100644 --- a/charon-ml/src/LlbcAst.ml +++ b/charon-ml/src/LlbcAst.ml @@ -6,11 +6,7 @@ include GAst include Generated_LlbcAst type expr_body = block gexpr_body [@@deriving show] -type fun_body = block body [@@deriving show] -type fun_decl = block gfun_decl [@@deriving show] - -(** LLBC crate *) -type crate = block gcrate [@@deriving show] +type fun_body = expr_body [@@deriving show] (* Ancestors for the type_decl visitors *) class ['self] iter_statement = diff --git a/charon-ml/src/LlbcAstUtils.ml b/charon-ml/src/LlbcAstUtils.ml index e798c3573..4229fc291 100644 --- a/charon-ml/src/LlbcAstUtils.ml +++ b/charon-ml/src/LlbcAstUtils.ml @@ -15,8 +15,15 @@ let fun_decl_list_from_crate (crate : crate) : fun_decl list = returns None *) let get_fun_args (fun_decl : fun_decl) : local list option = match fun_decl.body with - | Body body -> Some (GAstUtils.locals_get_input_vars body.locals) - | _ -> None + | StructuredBody { locals; _ } | UnstructuredBody { locals; _ } -> + Some (GAstUtils.locals_get_input_vars locals) + | TraitMethodWithoutDefaultBody + | OpaqueBody + | MissingBody + | TargetDispatchBody _ + | ExternBody _ + | IntrinsicBody _ + | ErrorBody _ -> None (** Check if a {!type:Charon.LlbcAst.statement} contains loops *) let block_has_loops (blk : block) : bool = @@ -34,7 +41,7 @@ let block_has_loops (blk : block) : bool = (** Check if a {!type:Charon.LlbcAst.fun_decl} contains loops *) let fun_decl_has_loops (fd : fun_decl) : bool = match fd.body with - | Body body -> block_has_loops body.body + | StructuredBody body -> block_has_loops body.body | _ -> false let crate_get_item_meta (m : crate) (id : item_id) : Types.item_meta option = @@ -93,24 +100,26 @@ class ['self] map_crate = in let body = match body with - | Body b -> Body (self#visit_expr_body env b) - | TraitMethodWithoutDefault -> TraitMethodWithoutDefault - | Extern sym -> Extern (self#visit_string env sym) - | Intrinsic { name; arg_names } -> - Intrinsic - { - name = self#visit_string env name; - arg_names = List.map (self#visit_string env) arg_names; - } - | TargetDispatch targets -> - TargetDispatch + | StructuredBody body -> + StructuredBody (self#visit_gexpr_body self#visit_block env body) + | UnstructuredBody _ -> (* ULLBC in LLBC visitor: ignore *) body + | TraitMethodWithoutDefaultBody -> TraitMethodWithoutDefaultBody + | ExternBody sym -> ExternBody (self#visit_string env sym) + | IntrinsicBody (name, arg_names) -> + IntrinsicBody + ( self#visit_string env name, + self#visit_list + (self#visit_option self#visit_string) + env arg_names ) + | TargetDispatchBody targets -> + TargetDispatchBody (self#visit_list (fun env (tgt, fref) -> (self#visit_string env tgt, self#visit_fun_decl_ref env fref)) env targets) - | Opaque -> Opaque - | Missing -> Missing - | Error err -> Error (self#visit_error env err) + | OpaqueBody -> OpaqueBody + | MissingBody -> MissingBody + | ErrorBody err -> ErrorBody (self#visit_error env err) in { def_id; @@ -239,21 +248,22 @@ class ['self] iter_crate = self#visit_item_source env src; self#visit_option self#visit_global_decl_id env is_global_initializer; match body with - | Body b -> self#visit_expr_body env b - | TraitMethodWithoutDefault -> () - | Extern sym -> self#visit_string env sym - | Intrinsic { name; arg_names } -> + | StructuredBody body -> self#visit_expr_body env body + | UnstructuredBody body -> (* ULLBC in LLBC visitor: ignore *) () + | TraitMethodWithoutDefaultBody -> () + | ExternBody sym -> self#visit_string env sym + | IntrinsicBody (name, arg_names) -> self#visit_string env name; - List.iter (self#visit_string env) arg_names - | TargetDispatch targets -> + self#visit_list (self#visit_option self#visit_string) env arg_names + | TargetDispatchBody targets -> self#visit_list (fun env (tgt, fref) -> self#visit_string env tgt; self#visit_fun_decl_ref env fref) env targets - | Opaque -> () - | Missing -> () - | Error err -> self#visit_error env err + | OpaqueBody -> () + | MissingBody -> () + | ErrorBody err -> self#visit_error env err method visit_declaration_group env (g : declaration_group) : unit = match g with diff --git a/charon-ml/src/LlbcOfJson.ml b/charon-ml/src/LlbcOfJson.ml deleted file mode 100644 index ec73cb475..000000000 --- a/charon-ml/src/LlbcOfJson.ml +++ /dev/null @@ -1,46 +0,0 @@ -(** Functions to load LLBC ASTs from json. - - See the comments for {!Charon.GAstOfJson} *) - -open OfJsonBasic -open Types -open LlbcAst -include GAstOfJson -include Generated_LlbcOfJson - -let expr_body_of_json (ctx : of_json_ctx) (js : json) : - (fun_body, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Structured", body) ] -> - let* body = gexpr_body_of_json block_of_json ctx body in - Ok (Body body) - | `Assoc [ ("Unstructured", _) ] -> - (* Some .llbc bodies are emitted in ULLBC mode (e.g. UNIT_METADATA). *) - Ok Opaque - | `String "TraitMethodWithoutDefault" -> Ok TraitMethodWithoutDefault - | `Assoc [ ("Extern", sym) ] -> - let* sym = string_of_json ctx sym in - Ok (Extern sym) - | `Assoc - [ ("Intrinsic", `Assoc [ ("name", name); ("arg_names", arg_names) ]) ] - -> - let* name = string_of_json ctx name in - let* arg_names = list_of_json string_of_json ctx arg_names in - Ok (Intrinsic { name; arg_names }) - | `Assoc [ ("TargetDispatch", targets) ] -> - let* targets = - list_of_json - (key_value_pair_of_json string_of_json fun_decl_ref_of_json) - ctx targets - in - Ok (TargetDispatch targets) - | `String "Opaque" -> Ok Opaque - | `String "Missing" -> Ok Missing - | `Assoc [ ("Error", e) ] -> - let* e = error_of_json ctx e in - Ok (GAst.Error e) - | _ -> Error "") - -let crate_of_json (js : json) : (crate, string) result = - gcrate_of_json expr_body_of_json js diff --git a/charon-ml/src/NameMatcher.ml b/charon-ml/src/NameMatcher.ml index 256010a46..349338f1a 100644 --- a/charon-ml/src/NameMatcher.ml +++ b/charon-ml/src/NameMatcher.ml @@ -238,7 +238,7 @@ end module VarMap = Collections.MakeMap (VarOrderedType) (** Context to lookup definitions *) -type 'fun_body ctx = { crate : 'fun_body GAst.gcrate } +type ctx = { crate : GAst.crate } let ctx_from_crate crate = { crate } let ctx_to_fmt_env { crate } = PrintUtils.of_crate crate @@ -450,7 +450,7 @@ let match_literal (pl : literal) (l : Values.literal) : bool = | LChar pv, VChar v -> Uchar.of_char pv = v | _ -> false -let rec match_name_with_generics (ctx : 'fun_body ctx) (c : match_config) +let rec match_name_with_generics (ctx : ctx) (c : match_config) ?(m : maps = mk_empty_maps ()) (p : pattern) (n : T.name) (g : T.generic_args) : bool = (* Handle monomorphized matching: if the name ends with a PeInstantiated @@ -529,13 +529,12 @@ let rec match_name_with_generics (ctx : 'fun_body ctx) (c : match_config) match_name_with_generics ctx c p n g | _ -> false -and match_name (ctx : 'fun_body ctx) (c : match_config) (p : pattern) - (n : T.name) : bool = +and match_name (ctx : ctx) (c : match_config) (p : pattern) (n : T.name) : bool + = match_name_with_generics ctx c p n TypesUtils.empty_generic_args -and match_pattern_with_type_id (ctx : 'fun_body ctx) (c : match_config) - (m : maps) (pid : pattern) (id : T.type_id) (generics : T.generic_args) : - bool = +and match_pattern_with_type_id (ctx : ctx) (c : match_config) (m : maps) + (pid : pattern) (id : T.type_id) (generics : T.generic_args) : bool = match id with | TAdtId id -> (* Lookup the type decl and match the name *) @@ -563,8 +562,8 @@ and match_pattern_with_literal_type (pty : pattern) (ty : T.literal_type) : bool | [ PWild ] -> true | _ -> false -and match_expr_with_ty (ctx : 'fun_body ctx) (c : match_config) (m : maps) - (pty : expr) (ty : T.ty) : bool = +and match_expr_with_ty (ctx : ctx) (c : match_config) (m : maps) (pty : expr) + (ty : T.ty) : bool = match (pty, ty) with | EComp pid, TAdt tref -> match_pattern_with_type_id ctx c m pid tref.id tref.generics @@ -621,8 +620,8 @@ and match_expr_with_ty (ctx : 'fun_body ctx) (c : match_config) (m : maps) match_expr_with_ty ctx c m pty ty | _ -> false -and match_expr_with_trait_impl_id (ctx : 'fun_body ctx) (c : match_config) - (ptr : expr) (impl_id : T.TraitImplId.id) : bool = +and match_expr_with_trait_impl_id (ctx : ctx) (c : match_config) (ptr : expr) + (impl_id : T.TraitImplId.id) : bool = (* Lookup the trait implementation *) let impl = T.TraitImplId.Map.find impl_id ctx.crate.trait_impls in (* Lookup the trait declaration *) @@ -634,7 +633,7 @@ and match_expr_with_trait_impl_id (ctx : 'fun_body ctx) (c : match_config) impl.impl_trait.generics | EPrimAdt _ | ERef _ | EVar _ | EArrow _ | ERawPtr _ -> false -and match_trait_decl_ref (ctx : 'fun_body ctx) (c : match_config) (m : maps) +and match_trait_decl_ref (ctx : ctx) (c : match_config) (m : maps) (pid : pattern) (tr : T.trait_decl_ref T.region_binder) : bool = (* Lookup the trait declaration *) let d = T.TraitDeclId.Map.find tr.binder_value.id ctx.crate.trait_decls in @@ -644,9 +643,9 @@ and match_trait_decl_ref (ctx : 'fun_body ctx) (c : match_config) (m : maps) match_name_with_generics ctx c ~m pid d.item_meta.name tr.binder_value.generics -and match_trait_decl_ref_item (ctx : 'fun_body ctx) (c : match_config) - (m : maps) (pid : pattern) (tr : T.trait_decl_ref T.region_binder) - (item_name : string) (generics : T.generic_args) : bool = +and match_trait_decl_ref_item (ctx : ctx) (c : match_config) (m : maps) + (pid : pattern) (tr : T.trait_decl_ref T.region_binder) (item_name : string) + (generics : T.generic_args) : bool = if c.match_with_trait_decl_refs then (* We match the trait decl ref *) (* We split the pattern between the trait decl ref and the associated item name *) @@ -663,12 +662,12 @@ and match_trait_decl_ref_item (ctx : 'fun_body ctx) (c : match_config) | _ -> false else raise (Failure "Unimplemented") -and match_trait_type (ctx : 'fun_body ctx) (c : match_config) (m : maps) - (pid : pattern) (tr : T.trait_ref) (type_name : string) : bool = +and match_trait_type (ctx : ctx) (c : match_config) (m : maps) (pid : pattern) + (tr : T.trait_ref) (type_name : string) : bool = match_trait_decl_ref_item ctx c m pid tr.trait_decl_ref type_name TypesUtils.empty_generic_args -and match_generic_args (ctx : 'fun_body ctx) (c : match_config) (m : maps) +and match_generic_args (ctx : ctx) (c : match_config) (m : maps) (pgenerics : generic_args) (generics : T.generic_args) : bool = log#ldebug (lazy @@ -676,7 +675,7 @@ and match_generic_args (ctx : 'fun_body ctx) (c : match_config) (m : maps) "match_generic_args: " ^ "\n- pgenerics: " ^ generic_args_to_string { tgt = TkPattern } pgenerics ^ "\n- generics: " - ^ PrintTypes.generic_args_to_string fmt_env generics)); + ^ Print.generic_args_to_string fmt_env generics)); let merged_generics = List.concat [ @@ -689,7 +688,7 @@ and match_generic_args (ctx : 'fun_body ctx) (c : match_config) (m : maps) List.for_all2 (match_generic_arg ctx c m) pgenerics merged_generics else false -and match_generic_arg (ctx : 'fun_body ctx) (c : match_config) (m : maps) +and match_generic_arg (ctx : ctx) (c : match_config) (m : maps) (pg : generic_arg) (g : mexpr) : bool = log#ldebug (lazy @@ -703,8 +702,8 @@ and match_generic_arg (ctx : 'fun_body ctx) (c : match_config) (m : maps) | GValue v, MCg { kind = CLiteral cg; _ } -> match_literal v cg | _ -> false -and match_expr_with_const_generic (ctx : 'fun_body ctx) (c : match_config) - (m : maps) (pcg : expr) (cg : T.constant_expr) : bool = +and match_expr_with_const_generic (ctx : ctx) (c : match_config) (m : maps) + (pcg : expr) (cg : T.constant_expr) : bool = match (pcg, cg.kind) with | EVar pv, _ -> opt_update_cmap c m pv cg | EComp pat, CGlobal gref -> @@ -722,14 +721,14 @@ let builtin_fun_id_to_string (fid : T.builtin_fun_id) : string = | Index { is_array; mutability; is_range } -> let ty = if is_array then "Array" else "Slice" in let op = if is_range then "SubSlice" else "Index" in - let mutability = PrintTypes.ref_kind_to_string mutability in + let mutability = Print.ref_kind_to_string mutability in ty ^ op ^ mutability | PtrFromParts mut -> let mut = if mut = RMut then "_mut" else "" in "std::ptr::from_raw_parts" ^ mut -let match_fn_ptr (ctx : 'fun_body ctx) (c : match_config) (p : pattern) - (func : T.fn_ptr) : bool = +let match_fn_ptr (ctx : ctx) (c : match_config) (p : pattern) (func : T.fn_ptr) + : bool = match func.kind with | FunId (FBuiltin fid) -> ( let to_name (s : string list) : T.name = @@ -797,12 +796,12 @@ let match_fn_ptr (ctx : 'fun_body ctx) (c : match_config) (p : pattern) match_trait_decl_ref_item ctx c (mk_empty_maps ()) p tr.trait_decl_ref method_name func.generics -let mk_name_with_generics_matcher (ctx : 'fun_body ctx) (c : match_config) - (pat : string) : T.name -> T.generic_args -> bool = +let mk_name_with_generics_matcher (ctx : ctx) (c : match_config) (pat : string) + : T.name -> T.generic_args -> bool = let pat = parse_pattern pat in match_name_with_generics ctx c pat -let mk_name_matcher (ctx : 'fun_body ctx) (c : match_config) (pat : string) : +let mk_name_matcher (ctx : ctx) (c : match_config) (pat : string) : T.name -> bool = let pat = parse_pattern pat in match_name ctx c pat @@ -953,9 +952,8 @@ let literal_to_pattern (_c : to_pat_config) (lit : Values.literal) : literal = raise (Failure "Float, string and byte string literals are not valid in names") -let rec name_with_generic_args_to_pattern_aux (ctx : 'fun_body ctx) - (c : to_pat_config) (n : T.name) (generics : generic_args option) : pattern - = +let rec name_with_generic_args_to_pattern_aux (ctx : ctx) (c : to_pat_config) + (n : T.name) (generics : generic_args option) : pattern = match n with | [] -> raise (Failure "Empty names are not valid") | [ e ] -> path_elem_with_generic_args_to_pattern ctx c e generics @@ -963,13 +961,11 @@ let rec name_with_generic_args_to_pattern_aux (ctx : 'fun_body ctx) path_elem_with_generic_args_to_pattern ctx c e None @ name_with_generic_args_to_pattern_aux ctx c n generics -and name_to_pattern_aux (ctx : 'fun_body ctx) (c : to_pat_config) (n : T.name) : - pattern = +and name_to_pattern_aux (ctx : ctx) (c : to_pat_config) (n : T.name) : pattern = name_with_generic_args_to_pattern_aux ctx c n None -and path_elem_with_generic_args_to_pattern (ctx : 'fun_body ctx) - (c : to_pat_config) (e : T.path_elem) (generics : generic_args option) : - pattern_elem list = +and path_elem_with_generic_args_to_pattern (ctx : ctx) (c : to_pat_config) + (e : T.path_elem) (generics : generic_args option) : pattern_elem list = match e with | PeIdent (s, d) -> begin let d = T.Disambiguator.to_int d in @@ -983,8 +979,8 @@ and path_elem_with_generic_args_to_pattern (ctx : 'fun_body ctx) are meant to match the logical structure, not the instantiation details *) [] -and impl_elem_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) - (impl : T.impl_elem) : pattern_elem = +and impl_elem_to_pattern (ctx : ctx) (c : to_pat_config) (impl : T.impl_elem) : + pattern_elem = match impl with | ImplElemTy bound_ty -> PImpl (ty_to_pattern ctx c bound_ty.binder_params bound_ty.binder_value) @@ -992,7 +988,7 @@ and impl_elem_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) let impl = T.TraitImplId.Map.find impl_id ctx.crate.trait_impls in PImpl (trait_decl_ref_to_pattern ctx c impl.generics impl.impl_trait) -and trait_decl_ref_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) +and trait_decl_ref_to_pattern (ctx : ctx) (c : to_pat_config) (params : T.generic_params) (tr : T.trait_decl_ref) : expr = (* Compute the constraints map *) let m = compute_constraints_map params in @@ -1003,8 +999,8 @@ and trait_decl_ref_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) (name_with_generic_args_to_pattern_aux ctx c d.item_meta.name (Some generics)) -and ty_to_pattern_aux (ctx : 'fun_body ctx) (c : to_pat_config) - (m : constraints) (ty : T.ty) : expr = +and ty_to_pattern_aux (ctx : ctx) (c : to_pat_config) (m : constraints) + (ty : T.ty) : expr = match ty with | TAdt tref -> ( let generics = generic_args_to_pattern ctx c m tref.generics in @@ -1067,12 +1063,11 @@ and ty_to_pattern_aux (ctx : 'fun_body ctx) (c : to_pat_config) let fmt_env = ctx_to_fmt_env ctx in raise (Failure - ("Can't convert type to pattern: " - ^ PrintTypes.ty_to_string fmt_env ty)) + ("Can't convert type to pattern: " ^ Print.ty_to_string fmt_env ty)) -and trait_ref_item_with_generics_to_pattern (ctx : 'fun_body ctx) - (c : to_pat_config) (m : constraints) (trait_ref : T.trait_ref) - (item_name : string) (item_generics : T.generic_args) : pattern = +and trait_ref_item_with_generics_to_pattern (ctx : ctx) (c : to_pat_config) + (m : constraints) (trait_ref : T.trait_ref) (item_name : string) + (item_generics : T.generic_args) : pattern = if c.use_trait_decl_refs then let trait_decl_ref = trait_ref.trait_decl_ref in let d = @@ -1095,15 +1090,15 @@ and trait_ref_item_with_generics_to_pattern (ctx : 'fun_body ctx) name else raise (Failure "TODO") -and ty_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) - (params : T.generic_params) (ty : T.ty) : expr = +and ty_to_pattern (ctx : ctx) (c : to_pat_config) (params : T.generic_params) + (ty : T.ty) : expr = (* Compute the constraints map *) let m = compute_constraints_map params in (* Convert the type *) ty_to_pattern_aux ctx c m ty -and constant_expr_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) - (m : constraints) (cg : T.constant_expr) : generic_arg = +and constant_expr_to_pattern (ctx : ctx) (c : to_pat_config) (m : constraints) + (cg : T.constant_expr) : generic_arg = match cg.kind with | CVar v -> GExpr (EVar (const_generic_var_to_pattern m v)) | CLiteral v -> GValue (literal_to_pattern c v) @@ -1113,8 +1108,8 @@ and constant_expr_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) GExpr (EComp n) | _ -> raise (Failure "TODO") -and generic_args_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) - (m : constraints) (generics : T.generic_args) : generic_args = +and generic_args_to_pattern (ctx : ctx) (c : to_pat_config) (m : constraints) + (generics : T.generic_args) : generic_args = let ({ regions; types; const_generics; trait_refs = _ } : T.generic_args) = generics in @@ -1130,8 +1125,7 @@ and generic_args_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) const_generics; ] -let name_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) (n : T.name) : - pattern = +let name_to_pattern (ctx : ctx) (c : to_pat_config) (n : T.name) : pattern = (* Convert the name to a pattern *) let pat = name_to_pattern_aux ctx c n in (* Sanity check: the name should match the pattern *) @@ -1148,7 +1142,7 @@ let name_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) (n : T.name) : (** We use the [params] to compute proper names for the variables. Note that it is safe to provide empty generic parameters. *) -let name_with_generics_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) +let name_with_generics_to_pattern (ctx : ctx) (c : to_pat_config) (params : T.generic_params) (n : T.name) (args : T.generic_args) : pattern = (* Convert the name to a pattern *) let pat = @@ -1170,7 +1164,7 @@ let name_with_generics_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) (** We use the [params] to compute proper names for the variables. Note that it is safe to provide empty generic parameters. *) -let fn_ptr_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) +let fn_ptr_to_pattern (ctx : ctx) (c : to_pat_config) (params : T.generic_params) (func : T.fn_ptr) : pattern = (* Convert the function pointer to a pattern *) let m = compute_constraints_map params in @@ -1209,7 +1203,7 @@ let fn_ptr_to_pattern (ctx : 'fun_body ctx) (c : to_pat_config) (lazy (let fmt_env = ctx_to_fmt_env ctx in "fn_ptr_to_pattern:" ^ "\n- fn_ptr: " - ^ PrintTypes.fn_ptr_to_string fmt_env func + ^ Print.fn_ptr_to_string fmt_env func ^ "\n- pattern: " ^ pattern_to_string { tgt = TkPattern } pat)); assert ( @@ -1487,7 +1481,7 @@ module NameMatcherMap = struct assert (replaced = None); nm - let match_name_with_generics_prefix (ctx : 'fun_body ctx) (c : match_config) + let match_name_with_generics_prefix (ctx : ctx) (c : match_config) (p : pattern) (n : T.name) (g : T.generic_args) : (T.name * T.generic_args) option = if List.length p = List.length n then @@ -1499,7 +1493,7 @@ module NameMatcherMap = struct if match_name ctx c p npre then Some (nend, g) else None else None - let rec find_with_generics_opt (ctx : 'fun_body ctx) (c : match_config) + let rec find_with_generics_opt (ctx : ctx) (c : match_config) (name : Types.name) (g : Types.generic_args) (m : 'a t) : 'a option = let (Node (node_v, children)) = m in (* Check if we reached the destination *) @@ -1513,8 +1507,8 @@ module NameMatcherMap = struct (* Explore the children *) find_with_generics_in_children_opt ctx c name g children - and find_with_generics_in_children_opt (ctx : 'fun_body ctx) - (c : match_config) (name : Types.name) (g : Types.generic_args) + and find_with_generics_in_children_opt (ctx : ctx) (c : match_config) + (name : Types.name) (g : Types.generic_args) (children : (pattern * 'a t) list) : 'a option = match children with | [] -> None @@ -1533,12 +1527,11 @@ module NameMatcherMap = struct (* Dive into the child *) find_with_generics_opt ctx c nend g child_tree) - let find_opt (ctx : 'fun_body ctx) (c : match_config) (name : Types.name) - (m : 'a t) : 'a option = + let find_opt (ctx : ctx) (c : match_config) (name : Types.name) (m : 'a t) : + 'a option = find_with_generics_opt ctx c name TypesUtils.empty_generic_args m - let mem (ctx : 'fun_body ctx) (c : match_config) (name : Types.name) - (m : 'a t) : bool = + let mem (ctx : ctx) (c : match_config) (name : Types.name) (m : 'a t) : bool = find_opt ctx c name m <> None let of_list (ls : (pattern * 'a) list) : 'a t = diff --git a/charon-ml/src/OfJson.ml b/charon-ml/src/OfJson.ml new file mode 100644 index 000000000..10107949f --- /dev/null +++ b/charon-ml/src/OfJson.ml @@ -0,0 +1,59 @@ +(** Functions to load (U)LLBC ASTs from json. + + Initially, we used [ppx_derive_yojson] to automate this. However, + [ppx_derive_yojson] expects formatting to be slightly different from what + [serde_rs] generates (because it uses [Yojson.Safe.t] and not + [Yojson.Basic.t]). *) + +open Yojson.Basic +open OfJsonBasic +open Identifiers +open Meta +open Values +open Types +open Scalars +open Expressions +open GAst +include Generated_OfJson + +let option_list_of_json of_json = list_of_json (option_of_json of_json) + +let crate_of_json (js : json) : (crate, string) result = + match js with + | `Assoc [ ("charon_version", charon_version); ("translated", translated) ] + | `Assoc [ ("charon_version", charon_version); ("translated", translated); _ ] + -> + (* Ensure the version is the one we support. *) + let* charon_version = string_of_json () charon_version in + if + not (String.equal charon_version CharonVersion.supported_charon_version) + then + Error + ("Incompatible version of charon: this program supports llbc emitted \ + by charon v" ^ CharonVersion.supported_charon_version + ^ " but attempted to read a file emitted by charon v" ^ charon_version + ^ ".") + else + let ctx = empty_of_json_ctx in + let* crate = translated_crate_of_json ctx translated in + let type_decls = TypeDeclId.map_of_indexed_list crate.type_decls in + let fun_decls = FunDeclId.map_of_indexed_list crate.fun_decls in + let global_decls = + GlobalDeclId.map_of_indexed_list crate.global_decls + in + let trait_decls = TraitDeclId.map_of_indexed_list crate.trait_decls in + let trait_impls = TraitImplId.map_of_indexed_list crate.trait_impls in + Ok + { + name = crate.crate_name; + options = crate.options; + target_information = crate.target_information; + declarations = Option.value ~default:[] crate.ordered_decls; + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + unit_metadata = Option.get crate.unit_metadata; + } + | _ -> combine_error_msgs js __FUNCTION__ (Error "") diff --git a/charon-ml/src/Print.ml b/charon-ml/src/Print.ml new file mode 100644 index 000000000..0899cb319 --- /dev/null +++ b/charon-ml/src/Print.ml @@ -0,0 +1,1499 @@ +(** Pretty-printing for types *) + +open Values +open Meta +open Types +open Expressions +open GAst +open TypesUtils +open GAstUtils +open PrintUtils + +type fmt_env = PrintUtils.fmt_env + +let integer_type_to_string = function + | Signed Isize -> "isize" + | Signed I8 -> "i8" + | Signed I16 -> "i16" + | Signed I32 -> "i32" + | Signed I64 -> "i64" + | Signed I128 -> "i128" + | Unsigned Usize -> "usize" + | Unsigned U8 -> "u8" + | Unsigned U16 -> "u16" + | Unsigned U32 -> "u32" + | Unsigned U64 -> "u64" + | Unsigned U128 -> "u128" + +let float_type_to_string = function + | F16 -> "f16" + | F32 -> "f32" + | F64 -> "f64" + | F128 -> "f128" + +let literal_type_to_string (ty : literal_type) : string = + match ty with + | TInt ity -> integer_type_to_string (Signed ity) + | TUInt uty -> integer_type_to_string (Unsigned uty) + | TFloat fty -> float_type_to_string fty + | TBool -> "bool" + | TChar -> "char" + +let big_int_to_string (bi : big_int) : string = Z.to_string bi + +let scalar_value_to_string (sv : scalar_value) : string = + big_int_to_string (Scalars.get_val sv) + ^ integer_type_to_string (Scalars.get_ty sv) + +let float_value_to_string (fv : float_value) : string = + fv.float_value ^ float_type_to_string fv.float_ty + +let literal_to_string (lit : literal) : string = + match lit with + | VScalar sv -> scalar_value_to_string sv + | VFloat fv -> float_value_to_string fv + | VBool b -> Bool.to_string b + | VChar c -> Uchar.to_string c + | VStr s -> "\"" ^ s ^ "\"" + | VByteStr bs -> "[" ^ String.concat ", " (List.map string_of_int bs) ^ "]" + +let region_param_to_string (rv : region_param) : string = + match rv.name with + | Some name -> name + | None -> RegionId.to_string rv.index + +let g_region_group_to_string (rid_to_string : 'rid -> string) + (id_to_string : 'id -> string) (gr : ('rid, 'id) g_region_group) : string = + let { id; regions; parents } = gr in + "{ id: " ^ id_to_string id ^ "; regions: [" + ^ String.concat ", " (List.map rid_to_string regions) + ^ "]; parents: [" + ^ String.concat ", " (List.map id_to_string parents) + ^ "] }" + +let region_var_group_to_string (gr : region_var_group) : string = + g_region_group_to_string RegionId.to_string RegionGroupId.to_string gr + +let region_var_groups_to_string (gl : region_var_groups) : string = + String.concat "\n" (List.map region_var_group_to_string gl) + +let ref_kind_to_string (rk : ref_kind) : string = + match rk with + | RMut -> "Mut" + | RShared -> "Shared" + +let builtin_ty_to_string (_ : builtin_ty) : string = "Box" + +let de_bruijn_var_to_pretty_string show_varid var : string = + match var with + | Bound (dbid, varid) -> show_de_bruijn_id dbid ^ "_" ^ show_varid varid + | Free varid -> show_varid varid + +let region_db_var_to_pretty_string (var : region_db_var) : string = + "'" ^ de_bruijn_var_to_pretty_string RegionId.to_string var + +let type_db_var_to_pretty_string (var : type_db_var) : string = + "T@" ^ de_bruijn_var_to_pretty_string TypeVarId.to_string var + +let type_var_id_to_pretty_string (id : type_var_id) : string = + "T@" ^ TypeVarId.to_string id + +let type_param_to_string (tv : type_param) : string = tv.name + +let const_generic_var_id_to_pretty_string (id : const_generic_var_id) : string = + "C@" ^ ConstGenericVarId.to_string id + +let const_generic_db_var_to_pretty_string (var : const_generic_db_var) : string + = + "C@" ^ de_bruijn_var_to_pretty_string ConstGenericVarId.to_string var + +let const_generic_param_to_string (v : const_generic_param) : string = v.name + +let trait_clause_id_to_pretty_string (id : trait_clause_id) : string = + "TraitClause@" ^ TraitClauseId.to_string id + +let trait_db_var_to_pretty_string (var : trait_db_var) : string = + "TraitClause@" ^ de_bruijn_var_to_pretty_string TraitClauseId.to_string var + +let trait_clause_id_to_string _ id = trait_clause_id_to_pretty_string id + +let type_decl_id_to_pretty_string (id : type_decl_id) : string = + "TypeDecl@" ^ TypeDeclId.to_string id + +let fun_decl_id_to_pretty_string (id : FunDeclId.id) : string = + "FunDecl@" ^ FunDeclId.to_string id + +let global_decl_id_to_pretty_string (id : GlobalDeclId.id) : string = + "GlobalDecl@" ^ GlobalDeclId.to_string id + +let trait_decl_id_to_pretty_string (id : trait_decl_id) : string = + "TraitDecl@" ^ TraitDeclId.to_string id + +let trait_impl_id_to_pretty_string (id : trait_impl_id) : string = + "TraitImpl@" ^ TraitImplId.to_string id + +let variant_id_to_pretty_string (id : variant_id) : string = + "Variant@" ^ VariantId.to_string id + +let field_id_to_pretty_string (id : field_id) : string = + "Field@" ^ FieldId.to_string id + +let lookup_var_in_env (env : fmt_env) + (find_in : generic_params -> 'id -> 'b option) (var : 'id de_bruijn_var) : + 'b option = + if List.length env.generics == 0 then None + else + let dbid, varid = + match var with + | Bound (dbid, varid) -> (dbid, varid) + | Free varid -> + let len = List.length env.generics in + let dbid = len - 1 in + (dbid, varid) + in + match List.nth_opt env.generics dbid with + | None -> None + | Some generics -> begin + match find_in generics varid with + | None -> None + | Some r -> Some r + end + +let region_db_var_to_string (env : fmt_env) (var : region_db_var) : string = + (* Note that the regions are not necessarily ordered following their indices *) + let find (generics : generic_params) varid = + List.find_opt (fun (v : region_param) -> v.index = varid) generics.regions + in + match lookup_var_in_env env find var with + | None -> region_db_var_to_pretty_string var + | Some r -> region_param_to_string r + +let type_db_var_to_string (env : fmt_env) (var : type_db_var) : string = + let find (generics : generic_params) varid = + List.find_opt (fun (v : type_param) -> v.index = varid) generics.types + in + match lookup_var_in_env env find var with + | None -> type_db_var_to_pretty_string var + | Some r -> type_param_to_string r + +let const_generic_db_var_to_string (env : fmt_env) (var : const_generic_db_var) + : string = + let find (generics : generic_params) varid = + List.find_opt + (fun (v : const_generic_param) -> v.index = varid) + generics.const_generics + in + match lookup_var_in_env env find var with + | None -> const_generic_db_var_to_pretty_string var + | Some r -> const_generic_param_to_string r + +let trait_db_var_to_string (env : fmt_env) (var : trait_db_var) : string = + let find (generics : generic_params) varid = + List.find_opt + (fun (v : trait_param) -> v.clause_id = varid) + generics.trait_clauses + in + match lookup_var_in_env env find var with + | None -> trait_db_var_to_pretty_string var + | Some r -> trait_clause_id_to_pretty_string r.clause_id + +let region_to_string (env : fmt_env) (r : region) : string = + match r with + | RStatic -> "'static" + | RErased -> "'_" + | RBody id -> "°" ^ RegionId.to_string id + | RVar var -> region_db_var_to_string env var + +let region_binder_to_string (value_to_string : fmt_env -> 'c -> string) + (env : fmt_env) (rb : 'c region_binder) : string = + let env = fmt_env_push_regions env rb.binder_regions in + let value = value_to_string env rb.binder_value in + match rb.binder_regions with + | [] -> value + | _ -> + "for <" + ^ String.concat "," (List.map region_param_to_string rb.binder_regions) + ^ "> " ^ value + +let rec type_id_to_string (env : fmt_env) (id : type_id) : string = + match id with + | TAdtId id -> type_decl_id_to_string env id + | TTuple -> "" + | TBuiltin aty -> ( + match aty with + | TBox -> "alloc::boxed::Box" + | TStr -> "str") + +and type_decl_id_to_string env def_id = + (* We don't want the printing functions to crash if the crate is partial *) + match TypeDeclId.Map.find_opt def_id env.crate.type_decls with + | None -> type_decl_id_to_pretty_string def_id + | Some def -> name_to_string env def.item_meta.name + +and type_decl_ref_to_string (env : fmt_env) (tref : type_decl_ref) : string = + match tref.id with + | TTuple -> + let params, trait_refs = generic_args_to_strings env tref.generics in + "(" ^ String.concat ", " params ^ ")" + | id -> + let id = type_id_to_string env id in + let generics = generic_args_to_string env tref.generics in + id ^ generics + +and fun_decl_id_to_string (env : fmt_env) (id : FunDeclId.id) : string = + match FunDeclId.Map.find_opt id env.crate.fun_decls with + | None -> fun_decl_id_to_pretty_string id + | Some def -> name_to_string env def.item_meta.name + +and fun_decl_ref_to_string (env : fmt_env) (fn : fun_decl_ref) : string = + let fun_id = fun_decl_id_to_string env fn.id in + let generics = generic_args_to_string env fn.generics in + fun_id ^ generics + +and global_decl_id_to_string env def_id = + match GlobalDeclId.Map.find_opt def_id env.crate.global_decls with + | None -> global_decl_id_to_pretty_string def_id + | Some def -> name_to_string env def.item_meta.name + +and global_decl_ref_to_string (env : fmt_env) (gr : global_decl_ref) : string = + let global_id = global_decl_id_to_string env gr.id in + let generics = generic_args_to_string env gr.generics in + global_id ^ generics + +and trait_decl_id_to_string env id = + match TraitDeclId.Map.find_opt id env.crate.trait_decls with + | None -> trait_decl_id_to_pretty_string id + | Some def -> name_to_string env def.item_meta.name + +and trait_impl_id_to_string env id = + match TraitImplId.Map.find_opt id env.crate.trait_impls with + | None -> trait_impl_id_to_pretty_string id + | Some def -> name_to_string env def.item_meta.name + +and trait_impl_ref_to_string (env : fmt_env) (iref : trait_impl_ref) : string = + let impl = trait_impl_id_to_string env iref.id in + let generics = generic_args_to_string env iref.generics in + impl ^ generics + +and provenance_to_string (env : fmt_env) (pv : provenance) : string = + match pv with + | ProvGlobal gref -> "prov_global(" ^ global_decl_ref_to_string env gref ^ ")" + | ProvFunction fn_ref -> "prov_fn(" ^ fun_decl_ref_to_string env fn_ref ^ ")" + | ProvUnknown -> "prov_unknown" + +and byte_to_string (env : fmt_env) (cv : byte) : string = + match cv with + | Uninit -> "uninit" + | Value b -> string_of_int b + | Provenance (p, i) -> + provenance_to_string env p ^ "[" ^ string_of_int i ^ "]" + +and const_aggregate_to_string (env : fmt_env) (tref : type_decl_ref) + opt_variant_id (fields : constant_expr list) : string = + let fields = List.map (constant_expr_to_string env) fields in + + match tref.id with + | TTuple -> "(" ^ String.concat ", " fields ^ ")" + | TAdtId def_id -> + let adt_name = type_decl_id_to_string env def_id in + let variant_name = + match opt_variant_id with + | None -> adt_name + | Some variant_id -> + adt_name ^ "::" ^ adt_variant_to_string env def_id variant_id + in + let fields = + match adt_field_names env def_id opt_variant_id with + | None -> "(" ^ String.concat ", " fields ^ ")" + | Some field_names -> + let fields = List.combine field_names fields in + let fields = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + fields + in + let fields = String.concat " " fields in + "{ " ^ fields ^ " }" + in + variant_name ^ " " ^ fields + | TBuiltin _ -> raise (Failure "Unreachable") + +and constant_expr_to_string (env : fmt_env) (cv : constant_expr) : string = + match cv.kind with + | CLiteral lit -> literal_to_string lit + | CVar var -> const_generic_db_var_to_string env var + | CTraitConst (trait_ref, const_name) -> + let trait_ref = trait_ref_to_string env trait_ref in + trait_ref ^ const_name + | CVTableRef trait_ref -> + let trait_ref = trait_ref_to_string env trait_ref in + "&vtable_of(" ^ trait_ref ^ ")" + | CFnDef fn_ptr | CFnPtr fn_ptr -> fn_ptr_to_string env fn_ptr + | CRawMemory bytes -> + "RawMemory([" + ^ String.concat ", " (List.map (byte_to_string env) bytes) + ^ "])" + | COpaque reason -> "Opaque(" ^ reason ^ ")" + | CAdt (variant_id, fields) -> begin + match cv.ty with + | TAdt tref -> const_aggregate_to_string env tref variant_id fields + | _ -> "malformed constant" + end + | CArray fields -> + "[" + ^ String.concat ", " (List.map (constant_expr_to_string env) fields) + ^ "]" + | CGlobal gref -> global_decl_ref_to_string env gref + | CPtrNoProvenance n -> "(" ^ Z.to_string n ^ " as *const _)" + | CRef (c, _) -> "&" ^ constant_expr_to_string env c + | CPtr (ref_kind, c, _) -> + let ref_kind = + match ref_kind with + | RShared -> "&raw const" + | RMut -> "&raw mut" + in + ref_kind ^ constant_expr_to_string env c + +and builtin_fun_id_to_string (aid : builtin_fun_id) : string = + match aid with + | BoxNew -> "alloc::boxed::Box::new" + | ArrayToSliceShared -> "@ArrayToSliceShared" + | ArrayToSliceMut -> "@ArrayToSliceMut" + | ArrayRepeat -> "@ArrayRepeat" + | Index { is_array; mutability; is_range } -> + let ty = if is_array then "Array" else "Slice" in + let op = if is_range then "SubSlice" else "Index" in + let mutability = ref_kind_to_string mutability in + "@" ^ ty ^ op ^ mutability + | PtrFromParts mut -> + let mut = if mut = RMut then "Mut" else "" in + "@PtrFromParts" ^ mut + +and fun_id_to_string (env : fmt_env) (fid : fun_id) : string = + match fid with + | FRegular fid -> fun_decl_id_to_string env fid + | FBuiltin aid -> builtin_fun_id_to_string aid + +and fn_ptr_kind_to_string (env : fmt_env) (r : fn_ptr_kind) : string = + match r with + | TraitMethod (trait_ref, method_name, _) -> + trait_ref_to_string env trait_ref ^ "::" ^ method_name + | FunId fid -> fun_id_to_string env fid + +and fn_ptr_to_string (env : fmt_env) (ptr : fn_ptr) : string = + let generics = generic_args_to_string env ptr.generics in + fn_ptr_kind_to_string env ptr.kind ^ generics + +and ty_to_string (env : fmt_env) (ty : ty) : string = + match ty with + | TAdt tref -> type_decl_ref_to_string env tref + | TVar tv -> type_db_var_to_string env tv + | TNever -> "!" + | TLiteral lit_ty -> literal_type_to_string lit_ty + | TTraitType (trait_ref, type_name) -> + let trait_ref = trait_ref_to_string env trait_ref in + trait_ref ^ "::" ^ type_name + | TRef (r, rty, ref_kind) -> ( + match ref_kind with + | RMut -> + "&" ^ region_to_string env r ^ " mut (" ^ ty_to_string env rty ^ ")" + | RShared -> + "&" ^ region_to_string env r ^ " (" ^ ty_to_string env rty ^ ")") + | TRawPtr (rty, ref_kind) -> ( + match ref_kind with + | RMut -> "*mut " ^ ty_to_string env rty + | RShared -> "*const " ^ ty_to_string env rty) + | TFnPtr binder -> + let env = fmt_env_push_regions env binder.binder_regions in + let { inputs; output; _ } = binder.binder_value in + let inputs = + "(" ^ String.concat ", " (List.map (ty_to_string env) inputs) ^ ") -> " + in + inputs ^ ty_to_string env output + | TFnDef f -> + let env = fmt_env_push_regions env f.binder_regions in + let fn = fn_ptr_to_string env f.binder_value in + fn + | TDynTrait pred -> + let regions, clauses = + generic_params_to_strings env pred.binder.binder_params + in + let reg_str = + match regions with + | [] -> "" + | r :: _ -> " + " ^ r + in + "dyn (" ^ String.concat " + " clauses ^ reg_str ^ ")" + | TArray (ty, len) -> + "[" ^ ty_to_string env ty ^ "; " ^ constant_expr_to_string env len ^ "]" + | TSlice ty -> "[" ^ ty_to_string env ty ^ "]" + | TPtrMetadata ty -> "PtrMetadata(" ^ ty_to_string env ty ^ ")" + | TError msg -> "type_error (\"" ^ msg ^ "\")" + +(** Return two lists: + - one for the regions, types, const generics + - one for the trait refs *) +and generic_args_to_strings (env : fmt_env) (generics : generic_args) : + string list * string list = + let { regions; types; const_generics; trait_refs } = generics in + let regions = List.map (region_to_string env) regions in + let types = List.map (ty_to_string env) types in + let cgs = List.map (constant_expr_to_string env) const_generics in + let params = List.flatten [ regions; types; cgs ] in + let trait_refs = List.map (trait_ref_to_string env) trait_refs in + (params, trait_refs) + +and generic_args_to_string (env : fmt_env) (generics : generic_args) : string = + let params, trait_refs = generic_args_to_strings env generics in + let params = + if params = [] then "" else "<" ^ String.concat ", " params ^ ">" + in + let trait_refs = + if trait_refs = [] then "" else "[" ^ String.concat ", " trait_refs ^ "]" + in + params ^ trait_refs + +and trait_ref_kind_to_string (env : fmt_env) + (implements : trait_decl_ref region_binder option) (kind : trait_ref_kind) : + string = + match kind with + | Self -> "Self" + | TraitImpl impl_ref -> trait_impl_ref_to_string env impl_ref + | BuiltinOrAuto _ -> + region_binder_to_string trait_decl_ref_to_string env + (Option.get implements) + | Clause id -> trait_db_var_to_string env id + | ParentClause (tref, clause_id) -> + let inst_id = trait_ref_to_string env tref in + let clause_id = trait_clause_id_to_string env clause_id in + "parent(" ^ inst_id ^ ")::" ^ clause_id + | ItemClause (tref, name, clause_id) -> + let inst_id = trait_ref_to_string env tref in + let clause_id = trait_clause_id_to_string env clause_id in + "item(" ^ inst_id ^ ")::" ^ name ^ "::" ^ clause_id + | Dyn -> + let trait = + region_binder_to_string trait_decl_ref_to_string env + (Option.get implements) + in + "dyn(" ^ trait ^ ")" + | UnknownTrait msg -> "UNKNOWN(" ^ msg ^ ")" + +and trait_ref_to_string (env : fmt_env) (tr : trait_ref) : string = + trait_ref_kind_to_string env (Some tr.trait_decl_ref) tr.kind + +and trait_decl_ref_to_string (env : fmt_env) (tr : trait_decl_ref) : string = + let trait_id = trait_decl_id_to_string env tr.id in + let generics = generic_args_to_string env tr.generics in + trait_id ^ generics + +and impl_elem_to_string (env : fmt_env) (elem : impl_elem) : string = + match elem with + | ImplElemTy bound_ty -> + (* Locally replace the generics and the predicates *) + let env = fmt_env_push_generics_and_preds env bound_ty.binder_params in + ty_to_string env bound_ty.binder_value + | ImplElemTrait impl_id -> begin + match TraitImplId.Map.find_opt impl_id env.crate.trait_impls with + | None -> trait_impl_id_to_string env impl_id + | Some impl -> ( + (* Locally replace the generics and the predicates *) + let env = fmt_env_push_generics_and_preds env impl.generics in + (* Put the first type argument aside (it gives the type for which we + implement the trait) *) + let { id; generics } : trait_decl_ref = impl.impl_trait in + match generics.types with + | ty :: types -> begin + let ty, types = Collections.List.pop generics.types in + let generics = { generics with types } in + let tr : trait_decl_ref = { id; generics } in + let ty = ty_to_string env ty in + let tr = trait_decl_ref_to_string env tr in + tr ^ " for " ^ ty + end + (* When monomorphizing, traits no longer take a `Self` argument, it's stored in the name *) + | [] -> trait_decl_ref_to_string env impl.impl_trait) + end + +and path_elem_to_string (env : fmt_env) (e : path_elem) : string = + match e with + | PeIdent (s, d) -> + let d = + if d = Disambiguator.zero then "" else "#" ^ Disambiguator.to_string d + in + s ^ d + | PeImpl impl -> "{" ^ impl_elem_to_string env impl ^ "}" + | PeInstantiated binder -> + let env = fmt_env_push_generics_and_preds env binder.binder_params in + let explicits, _ = generic_args_to_strings env binder.binder_value in + "<" ^ String.concat ", " explicits ^ ">" + | PeTarget target -> target + +and name_to_string (env : fmt_env) (n : name) : string = + let name = List.map (path_elem_to_string env) n in + String.concat "::" name + +and raw_attribute_to_string (attr : raw_attribute) : string = + let args = + match attr.args with + | None -> "" + | Some args -> "(" ^ args ^ ")" + in + attr.path ^ args + +and trait_param_to_string (env : fmt_env) (clause : trait_param) : string = + let clause_id = trait_clause_id_to_string env clause.clause_id in + let trait = + region_binder_to_string trait_decl_ref_to_string env clause.trait + in + "[" ^ clause_id ^ "]: " ^ trait + +and generic_params_to_strings (env : fmt_env) (generics : generic_params) : + string list * string list = + let ({ regions; types; const_generics; trait_clauses; _ } : generic_params) = + generics + in + let regions = List.map region_param_to_string regions in + let types = List.map type_param_to_string types in + let cgs = List.map const_generic_param_to_string const_generics in + let params = List.flatten [ regions; types; cgs ] in + let trait_clauses = List.map (trait_param_to_string env) trait_clauses in + (params, trait_clauses) + +and adt_variant_to_string (env : fmt_env) (def_id : TypeDeclId.id) + (variant_id : VariantId.id) : string = + match TypeDeclId.Map.find_opt def_id env.crate.type_decls with + | None -> + type_decl_id_to_pretty_string def_id + ^ "::" + ^ variant_id_to_pretty_string variant_id + | Some def -> begin + match def.kind with + | Enum variants -> + let variant = VariantId.nth variants variant_id in + name_to_string env def.item_meta.name ^ "::" ^ variant.variant_name + | _ -> raise (Failure "Unreachable") + end + +and adt_field_names (env : fmt_env) (def_id : TypeDeclId.id) + (opt_variant_id : VariantId.id option) : string list option = + match TypeDeclId.Map.find_opt def_id env.crate.type_decls with + | None -> None + | Some { kind = Opaque; _ } -> None + | Some def -> + let fields = type_decl_get_fields def opt_variant_id in + (* There are two cases: either all the fields have names, or none + of them has names *) + let has_names = + List.exists (fun f -> Option.is_some f.field_name) fields + in + if has_names then + let fields = List.map (fun f -> Option.get f.field_name) fields in + Some fields + else None + +let field_to_string env (f : field) : string = + match f.field_name with + | Some field_name -> field_name ^ " : " ^ ty_to_string env f.field_ty + | None -> ty_to_string env f.field_ty + +let variant_to_string env (v : variant) : string = + v.variant_name ^ "(" + ^ String.concat ", " (List.map (field_to_string env) v.fields) + ^ ")" + +let trait_type_constraint_to_string (env : fmt_env) + (ttc : trait_type_constraint) : string = + let { trait_ref; type_name; ty } = ttc in + let trait_ref = trait_ref_to_string env trait_ref in + let ty = ty_to_string env ty in + trait_ref ^ "::" ^ type_name ^ " = " ^ ty + +(** Helper to format "where" clauses *) +let clauses_to_string (indent : string) (indent_incr : string) + (clauses : string list) : string = + if clauses = [] then "" + else + let env_clause s = indent ^ indent_incr ^ s ^ "," in + let clauses = List.map env_clause clauses in + "\n" ^ indent ^ "where\n" ^ String.concat "\n" clauses + +(** Helper to format "where" clauses *) +let predicates_and_trait_clauses_to_string (env : fmt_env) (indent : string) + (indent_incr : string) (generics : generic_params) : string list * string = + let params, trait_clauses = generic_params_to_strings env generics in + let region_to_string = region_to_string env in + let regions_outlive = + let outlive_to_string _ (x, y) = + region_to_string x ^ " : " ^ region_to_string y + in + List.map + (region_binder_to_string outlive_to_string env) + generics.regions_outlive + in + let types_outlive = + let outlive_to_string _ (x, y) = + ty_to_string env x ^ " : " ^ region_to_string y + in + List.map + (region_binder_to_string outlive_to_string env) + generics.types_outlive + in + let trait_type_constraints = + List.map + (region_binder_to_string trait_type_constraint_to_string env) + generics.trait_type_constraints + in + (* Split between the inherited clauses and the local clauses *) + let clauses = + clauses_to_string indent indent_incr + (List.concat + [ + trait_clauses; regions_outlive; types_outlive; trait_type_constraints; + ]) + in + (params, clauses) + +let type_decl_to_string (env : fmt_env) (def : type_decl) : string = + (* Locally update the generics and the predicates *) + let env = fmt_env_push_generics_and_preds env def.generics in + let params, clauses = + predicates_and_trait_clauses_to_string env "" " " def.generics + in + + let name = name_to_string env def.item_meta.name in + let params = + if params <> [] then "<" ^ String.concat ", " params ^ ">" else "" + in + match def.kind with + | Struct fields -> + if fields <> [] then + let fields = + String.concat "" + (List.map (fun f -> "\n " ^ field_to_string env f ^ ",") fields) + in + "struct " ^ name ^ params ^ clauses ^ "\n{" ^ fields ^ "\n}" + else "struct " ^ name ^ params ^ clauses ^ "{}" + | Enum variants -> + let variants = + List.map (fun v -> "| " ^ variant_to_string env v) variants + in + let variants = String.concat "\n" variants in + "enum " ^ name ^ params ^ clauses ^ "\n =\n" ^ variants + | Union fields -> + if fields <> [] then + let fields = + String.concat "" + (List.map (fun f -> "\n " ^ field_to_string env f ^ ",") fields) + in + "union " ^ name ^ params ^ clauses ^ "\n{" ^ fields ^ "\n}" + else "union " ^ name ^ params ^ clauses ^ "{}" + | Alias ty -> "type " ^ name ^ params ^ clauses ^ " = " ^ ty_to_string env ty + | Opaque -> "opaque type " ^ name ^ params ^ clauses + | TDeclError err -> "error(\"" ^ err ^ "\")" + +let adt_field_to_string (env : fmt_env) (def_id : TypeDeclId.id) + (opt_variant_id : VariantId.id option) (field_id : FieldId.id) : + string option = + match TypeDeclId.Map.find_opt def_id env.crate.type_decls with + | None -> None + | Some { kind = Opaque; _ } -> None + | Some def -> + let fields = type_decl_get_fields def opt_variant_id in + let field = FieldId.nth fields field_id in + field.field_name + +let local_id_to_pretty_string (id : local_id) : string = + "v@" ^ LocalId.to_string id + +let local_to_string (v : local) : string = + match v.name with + | None -> local_id_to_pretty_string v.index + | Some name -> name ^ "^" ^ LocalId.to_string v.index + +let local_id_to_string (env : fmt_env) (id : LocalId.id) : string = + match List.find_opt (fun (i, _) -> i = id) env.locals with + | None -> local_id_to_pretty_string id + | Some (_, name) -> ( + match name with + | None -> local_id_to_pretty_string id + | Some name -> name ^ "^" ^ LocalId.to_string id) + +let (var_id_to_pretty_string + [@ocaml.alert deprecated "use [local_id_to_pretty_string] instead"]) = + local_id_to_pretty_string + +let (var_id_to_string + [@ocaml.alert deprecated "use [local_id_to_string] instead"]) = + local_id_to_string + +let (var_to_string [@ocaml.alert deprecated "use [local_to_string] instead"]) = + local_to_string + +let rec projection_elem_to_string (env : fmt_env) (sub : string) + (pe : projection_elem) : string = + match pe with + | Deref -> "*(" ^ sub ^ ")" + | ProjIndex (off, from_end) -> + let idx_pre = if from_end then "-" else "" in + "(" ^ sub ^ ")[" ^ idx_pre ^ operand_to_string env off ^ "]" + | Subslice (from, to_, from_end) -> + let idx_pre = if from_end then "-" else "" in + "(" ^ sub ^ ")[" ^ idx_pre ^ operand_to_string env from ^ ".." + ^ operand_to_string env to_ ^ "]" + | Field (ProjTuple _, fid) -> "(" ^ sub ^ ")." ^ FieldId.to_string fid + | Field (ProjAdt (adt_id, opt_variant_id), fid) -> ( + let field_name = + match adt_field_to_string env adt_id opt_variant_id fid with + | Some field_name -> field_name + | None -> FieldId.to_string fid + in + match opt_variant_id with + | None -> "(" ^ sub ^ ")." ^ field_name + | Some variant_id -> + let variant_name = adt_variant_to_string env adt_id variant_id in + "(" ^ sub ^ " as " ^ variant_name ^ ")." ^ field_name) + | PtrMetadata -> sub ^ ".metadata" + +and place_to_string (env : fmt_env) (p : place) : string = + match p.kind with + | PlaceLocal var_id -> local_id_to_string env var_id + | PlaceProjection (subplace, pe) -> + let subplace = place_to_string env subplace in + projection_elem_to_string env subplace pe + | PlaceGlobal global_ref -> + let generics = generic_args_to_string env global_ref.generics in + global_decl_id_to_string env global_ref.id ^ generics + +and cast_kind_to_string (env : fmt_env) (cast : cast_kind) : string = + match cast with + | CastScalar (src, tgt) -> + "cast<" ^ literal_type_to_string src ^ "," ^ literal_type_to_string tgt + ^ ">" + | CastFnPtr (src, tgt) | CastRawPtr (src, tgt) | CastTransmute (src, tgt) -> + "cast<" ^ ty_to_string env src ^ "," ^ ty_to_string env tgt ^ ">" + | CastUnsize (src, tgt, _) -> + "unsize<" ^ ty_to_string env src ^ "," ^ ty_to_string env tgt ^ ">" + | CastConcretize (src, tgt) -> + "concretize<" ^ ty_to_string env src ^ "," ^ ty_to_string env tgt ^ ">" + +and nullop_to_string (env : fmt_env) (op : nullop) : string = + match op with + | SizeOf -> "size_of" + | AlignOf -> "align_of" + | OffsetOf _ -> "offset_of(?)" + | UbChecks -> "ub_checks" + | ContractChecks -> "contract_checks" + | OverflowChecks -> "overflow_checks" + +and unop_to_string (env : fmt_env) (unop : unop) : string = + match unop with + | Not -> "¬" + | Neg om -> overflow_mode_to_string om ^ ".-" + | Cast cast_kind -> cast_kind_to_string env cast_kind + +and overflow_mode_to_string (mode : overflow_mode) : string = + match mode with + | OWrap -> "wrap" + | OUB -> "ub" + | OPanic -> "panic" + +and binop_to_string (binop : binop) : string = + match binop with + | BitXor -> "^" + | BitAnd -> "&" + | BitOr -> "|" + | Eq -> "==" + | Lt -> "<" + | Le -> "<=" + | Ne -> "!=" + | Ge -> ">=" + | Gt -> ">" + | Div om -> overflow_mode_to_string om ^ "./" + | Rem om -> overflow_mode_to_string om ^ ".%" + | Add om -> overflow_mode_to_string om ^ ".+" + | Sub om -> overflow_mode_to_string om ^ ".-" + | Mul om -> overflow_mode_to_string om ^ ".*" + | Shl om -> overflow_mode_to_string om ^ ".<<" + | Shr om -> overflow_mode_to_string om ^ ".>>" + | AddChecked -> "checked.+" + | SubChecked -> "checked.-" + | MulChecked -> "checked.*" + | Cmp -> "cmp" + | Offset -> "offset" + +and operand_to_string (env : fmt_env) (op : operand) : string = + match op with + | Copy p -> "copy " ^ place_to_string env p + | Move p -> "move " ^ place_to_string env p + | Constant cv -> constant_expr_to_string env cv + +and aggregate_to_string (env : fmt_env) (agg : aggregate_kind) + (fields : operand list) : string = + let fields = List.map (operand_to_string env) fields in + match agg with + | AggregatedAdt (tref, opt_variant_id, opt_field_id) -> ( + match tref.id with + | TTuple -> "(" ^ String.concat ", " fields ^ ")" + | TAdtId def_id -> + let adt_name = type_decl_id_to_string env def_id in + let variant_name = + match opt_variant_id with + | None -> adt_name + | Some variant_id -> + adt_name ^ "::" ^ adt_variant_to_string env def_id variant_id + in + let fields = + match adt_field_names env def_id opt_variant_id with + | None -> "(" ^ String.concat ", " fields ^ ")" + | Some field_names -> + let field_names = + match opt_field_id with + | None -> field_names + (* Only keep the selected field *) + | Some field_id -> + [ List.nth field_names (FieldId.to_int field_id) ] + in + let fields = List.combine field_names fields in + let fields = + List.map + (fun (field, value) -> field ^ " = " ^ value ^ ";") + fields + in + let fields = String.concat " " fields in + "{ " ^ fields ^ " }" + in + variant_name ^ " " ^ fields + | TBuiltin _ -> raise (Failure "Unreachable")) + | AggregatedArray (_ty, _cg) -> "[" ^ String.concat ", " fields ^ "]" + | AggregatedRawPtr (_, refk) -> + let refk = + match refk with + | RShared -> "&raw const" + | RMut -> "&raw mut" + in + refk ^ " (" ^ String.concat ", " fields ^ ")" + +and rvalue_to_string (env : fmt_env) (rv : rvalue) : string = + match rv with + | Use op -> operand_to_string env op + | RvRef (p, bk, op) -> begin + let op = operand_to_string env op in + let p = place_to_string env p in + match bk with + | BShared -> "&(" ^ p ^ ", " ^ op ^ ")" + | BMut -> "&mut (" ^ p ^ ", " ^ op ^ ")" + | BTwoPhaseMut -> "&two-phase (" ^ p ^ ", " ^ op ^ ")" + | BUniqueImmutable -> "&uniq (" ^ p ^ ", " ^ op ^ ")" + | BShallow -> "&shallow (" ^ p ^ ", " ^ op ^ ")" + end + | RawPtr (p, pk, op) -> begin + let op = operand_to_string env op in + let p = place_to_string env p in + match pk with + | RShared -> "&raw const (" ^ p ^ ", " ^ op ^ ")" + | RMut -> "&raw mut (" ^ p ^ ", " ^ op ^ ")" + end + | NullaryOp (op, ty) -> + nullop_to_string env op ^ "<" ^ ty_to_string env ty ^ ">" + | UnaryOp (unop, op) -> + unop_to_string env unop ^ " " ^ operand_to_string env op + | BinaryOp (binop, op1, op2) -> + operand_to_string env op1 ^ " " ^ binop_to_string binop ^ " " + ^ operand_to_string env op2 + | Discriminant p -> "discriminant(" ^ place_to_string env p ^ ")" + | Len (place, ty, const_generics) -> + let const_generics = + match const_generics with + | None -> [] + | Some cg -> [ cg ] + in + "len<" + ^ String.concat ", " + (ty_to_string env ty + :: List.map (constant_expr_to_string env) const_generics) + ^ ">(" ^ place_to_string env place ^ ")" + | Repeat (v, _, len) -> + "[" ^ operand_to_string env v ^ ";" + ^ constant_expr_to_string env len + ^ "]" + | ShallowInitBox (op, _) -> + "shallow-init-box(" ^ operand_to_string env op ^ ")" + | Aggregate (akind, ops) -> aggregate_to_string env akind ops + +let item_id_to_string (id : item_id) : string = + match id with + | IdFun id -> FunDeclId.to_string id + | IdGlobal id -> GlobalDeclId.to_string id + | IdType id -> TypeDeclId.to_string id + | IdTraitDecl id -> TraitDeclId.to_string id + | IdTraitImpl id -> TraitImplId.to_string id + +let fn_operand_to_string (env : fmt_env) (op : fn_operand) : string = + match op with + | FnOpRegular func -> fn_ptr_to_string env func + | FnOpDynamic op -> "(" ^ operand_to_string env op ^ ")" + +let call_to_string (env : fmt_env) (indent : string) (call : call) : string = + let func = fn_operand_to_string env call.func in + let args = List.map (operand_to_string env) call.args in + let args = "(" ^ String.concat ", " args ^ ")" in + let dest = place_to_string env call.dest in + indent ^ dest ^ " := move " ^ func ^ args + +let assertion_to_string (env : fmt_env) (a : assertion) : string = + let cond = operand_to_string env a.cond in + if a.expected then "assert(" ^ cond ^ ")" else "assert(¬" ^ cond ^ ")" + +let abort_kind_to_string (env : fmt_env) (a : abort_kind) : string = + match a with + | Panic None -> "panic" + | Panic (Some name) -> "panic(" ^ name_to_string env name ^ ")" + | UndefinedBehavior -> "undefined_behavior" + | UnwindTerminate -> "unwind_terminate" + +(** Small helper *) +let fun_sig_with_name_to_string (env : fmt_env) (indent : string) + (indent_incr : string) (attribute : string option) (name : string option) + (args : local list option) (sg : bound_fun_sig) : string = + let { item_binder_params = generics; item_binder_value = sg; _ } = sg in + let env = fmt_env_replace_generics_and_preds env generics in + let ty_to_string = ty_to_string env in + + (* Unsafe keyword *) + let unsafe = if sg.is_unsafe then "unsafe " else "" in + + (* Generics and predicates *) + let params, clauses = + predicates_and_trait_clauses_to_string env indent indent_incr generics + in + let params = + if params = [] then "" else "<" ^ String.concat ", " params ^ ">" + in + + (* Return type *) + let ret_ty = sg.output in + let ret_ty = if ty_is_unit ret_ty then "" else " -> " ^ ty_to_string ret_ty in + + (* Arguments *) + let args = + match args with + | None -> + let args = List.map ty_to_string sg.inputs in + String.concat ", " args + | Some args -> + let args = List.combine args sg.inputs in + let args = + List.map + (fun (var, rty) -> local_to_string var ^ " : " ^ ty_to_string rty) + args + in + String.concat ", " args + in + + (* Put everything together *) + let attribute = + match attribute with + | None -> "" + | Some attr -> attr ^ " " + in + let name = + match name with + | None -> "" + | Some name -> " " ^ name + in + indent ^ attribute ^ unsafe ^ "fn" ^ name ^ params ^ "(" ^ args ^ ")" ^ ret_ty + ^ clauses + +let fun_sig_to_string (env : fmt_env) (indent : string) (indent_incr : string) + (sg : fun_sig item_binder) : string = + fun_sig_with_name_to_string env indent indent_incr None None None sg + +let locals_to_string (env : fmt_env) (indent : string) (locals : locals) : + string = + locals.locals + |> List.map (fun var -> + indent ^ local_to_string var ^ " : " + ^ ty_to_string env var.local_ty + ^ ";") + |> String.concat "\n" + +let trait_decl_to_string (env : fmt_env) (indent : string) + (indent_incr : string) (def : trait_decl) : string = + (* Locally update the environment *) + let env = fmt_env_replace_generics_and_preds env def.generics in + + let ty_to_string = ty_to_string env in + + (* Name *) + let name = name_to_string env def.item_meta.name in + + (* Generics and predicates *) + let params, clauses = + predicates_and_trait_clauses_to_string env indent indent_incr def.generics + in + let params = + if params = [] then "" else "<" ^ String.concat ", " params ^ ">" + in + + let indent1 = indent ^ indent_incr in + + let items = + let parent_clauses = + List.map + (fun clause -> + indent1 ^ "parent_clause_" + ^ TraitClauseId.to_string clause.clause_id + ^ " : " + ^ trait_param_to_string env clause + ^ "\n") + def.implied_clauses + in + let consts = + List.map + (fun c -> + let ty = ty_to_string c.ty in + indent1 ^ "const " ^ c.name ^ " : " ^ ty ^ "\n") + def.consts + in + let types = + List.map + (fun (bound_ty : trait_assoc_ty binder) -> + let env = + fmt_env_push_generics_and_preds env bound_ty.binder_params + in + (* TODO: print clauses too *) + let params, _clauses = + predicates_and_trait_clauses_to_string env "" " " def.generics + in + let params = + if params <> [] then "<" ^ String.concat ", " params ^ ">" else "" + in + indent1 ^ "type " ^ bound_ty.binder_value.name ^ params ^ "\n") + def.types + in + let methods = + List.map + (fun (m : trait_method binder) -> + indent1 ^ "fn " ^ m.binder_value.name ^ " : " + ^ fun_decl_id_to_string env m.binder_value.item.id + ^ "\n") + def.methods + in + let items = List.concat [ parent_clauses; consts; types; methods ] in + if items = [] then "" else "\n{\n" ^ String.concat "" items ^ "}" + in + + "trait " ^ name ^ params ^ clauses ^ items + +let trait_impl_to_string (env : fmt_env) (indent : string) + (indent_incr : string) (def : trait_impl) : string = + (* Locally update the environment *) + let env = fmt_env_replace_generics_and_preds env def.generics in + + (* Name *) + let name = name_to_string env def.item_meta.name in + + (* Generics and predicates *) + let params, clauses = + predicates_and_trait_clauses_to_string env indent indent_incr def.generics + in + let params = + if params = [] then "" else "<" ^ String.concat ", " params ^ ">" + in + + let indent1 = indent ^ indent_incr in + + let items = + (* The parent clauses are given by the trait refs of the implemented trait *) + let parent_clauses = + Collections.List.mapi + (fun i trait_ref -> + indent1 ^ "parent_clause" ^ string_of_int i ^ " = " + ^ trait_ref_to_string env trait_ref + ^ "\n") + def.implied_trait_refs + in + let consts = + List.map + (fun (name, gref) -> + let gref = global_decl_ref_to_string env gref in + indent1 ^ "const " ^ name ^ " = " ^ gref ^ "\n") + def.consts + in + let types = + List.map + (fun (name, bound_ty) -> + let env = + fmt_env_push_generics_and_preds env bound_ty.binder_params + in + let params, _clauses = + predicates_and_trait_clauses_to_string env "" " " def.generics + in + let params = + if params <> [] then "<" ^ String.concat ", " params ^ ">" else "" + in + indent1 ^ "type " ^ name ^ params ^ " = " + ^ ty_to_string env bound_ty.binder_value.value + ^ "\n") + def.types + in + let env_method ((name, f) : _ * fun_decl_ref binder) = + indent1 ^ "fn " ^ name ^ " : " + ^ fun_decl_id_to_string env f.binder_value.id + ^ "\n" + in + let methods = List.map env_method def.methods in + let items = List.concat [ parent_clauses; consts; types; methods ] in + if items = [] then "" else "\n{\n" ^ String.concat "" items ^ "}" + in + + let impl_trait = trait_decl_ref_to_string env def.impl_trait in + "impl" ^ params ^ " " ^ name ^ params ^ " : " ^ impl_trait ^ clauses ^ items + +let global_decl_to_string (env : fmt_env) (indent : string) + (_indent_incr : string) (def : global_decl) : string = + (* Locally update the generics and the predicates *) + let env = fmt_env_replace_generics_and_preds env def.generics in + let params, clauses = + predicates_and_trait_clauses_to_string env "" " " def.generics + in + let params = + if params <> [] then "<" ^ String.concat ", " params ^ ">" else "" + in + + (* Global name *) + let name = name_to_string env def.item_meta.name in + + (* Type *) + let ty = ty_to_string env def.ty in + + let body_id = fun_decl_id_to_string env def.init in + indent ^ "global " ^ name ^ params ^ clauses ^ " : " ^ ty ^ " = " ^ body_id + +module Llbc = struct + (** Pretty-printing for LLBC AST (generic functions) *) + + open LlbcAst + + let rec statement_to_string (env : fmt_env) (indent : string) + (indent_incr : string) (st : statement) : string = + statement_kind_to_string env indent indent_incr st.kind + + and statement_kind_to_string (env : fmt_env) (indent : string) + (indent_incr : string) (st : statement_kind) : string = + match st with + | Assign (p, rv) -> + indent ^ place_to_string env p ^ " := " ^ rvalue_to_string env rv + | SetDiscriminant (p, variant_id) -> + (* TODO: improve this to lookup the variant name by using the def id *) + indent ^ "set_discriminant(" ^ place_to_string env p ^ ", " + ^ VariantId.to_string variant_id + ^ ")" + | CopyNonOverlapping { src; dst; count } -> + indent ^ "copy_non_overlapping(" ^ operand_to_string env src ^ ", " + ^ operand_to_string env dst ^ ", " + ^ operand_to_string env count + ^ ")" + | StorageLive var_id -> + indent ^ "storage_live " ^ local_id_to_string env var_id + | StorageDead var_id -> + indent ^ "storage_dead " ^ local_id_to_string env var_id + | PlaceMention place -> indent ^ "_ := " ^ place_to_string env place + | Drop (p, _, _) -> indent ^ "drop " ^ place_to_string env p + | Assert (asrt, abort_kind) -> + indent + ^ assertion_to_string env asrt + ^ " else " + ^ abort_kind_to_string env abort_kind + | Call call -> call_to_string env indent call + | Abort (Panic _) -> indent ^ "panic" + | Abort UndefinedBehavior -> indent ^ "undefined_behavior" + | Abort UnwindTerminate -> indent ^ "unwind_terminate" + | Return -> indent ^ "return" + | Break i -> indent ^ "break " ^ string_of_int i + | Continue i -> indent ^ "continue " ^ string_of_int i + | Nop -> indent ^ "nop" + | Switch switch -> ( + match switch with + | If (op, true_st, false_st) -> + let op = operand_to_string env op in + let inner_indent = indent ^ indent_incr in + let inner_to_string = + block_to_string env inner_indent indent_incr + in + let true_st = inner_to_string true_st in + let false_st = inner_to_string false_st in + indent ^ "if (" ^ op ^ ") {\n" ^ true_st ^ "\n" ^ indent ^ "}\n" + ^ indent ^ "else {\n" ^ false_st ^ "\n" ^ indent ^ "}" + | SwitchInt (op, _ty, branches, otherwise) -> + let op = operand_to_string env op in + let indent1 = indent ^ indent_incr in + let indent2 = indent1 ^ indent_incr in + let inner_to_string2 = block_to_string env indent2 indent_incr in + let branches = + List.map + (fun (svl, be) -> + let svl = + List.map (fun sv -> "| " ^ literal_to_string sv) svl + in + let svl = String.concat " " svl in + indent ^ svl ^ " => {\n" ^ inner_to_string2 be ^ "\n" + ^ indent1 ^ "}") + branches + in + let branches = String.concat "\n" branches in + let branches = + branches ^ "\n" ^ indent1 ^ "_ => {\n" + ^ inner_to_string2 otherwise ^ "\n" ^ indent1 ^ "}" + in + indent ^ "switch (" ^ op ^ ") {\n" ^ branches ^ "\n" ^ indent ^ "}" + | Match (p, branches, otherwise) -> + let p = place_to_string env p in + let indent1 = indent ^ indent_incr in + let indent2 = indent1 ^ indent_incr in + let inner_to_string2 = block_to_string env indent2 indent_incr in + let branches = + List.map + (fun (svl, be) -> + let svl = + List.map (fun sv -> "| " ^ VariantId.to_string sv) svl + in + let svl = String.concat " " svl in + indent ^ svl ^ " => {\n" ^ inner_to_string2 be ^ "\n" + ^ indent1 ^ "}") + branches + in + let branches = String.concat "\n" branches in + let otherwise = + match otherwise with + | None -> "" + | Some otherwise -> + "\n" ^ indent1 ^ "_ => {\n" ^ inner_to_string2 otherwise + ^ "\n" ^ indent1 ^ "}" + in + let branches = branches ^ otherwise in + indent ^ "match (" ^ p ^ ") {\n" ^ branches ^ "\n" ^ indent ^ "}") + | Loop loop_blk -> + indent ^ "loop {\n" + ^ block_to_string env (indent ^ indent_incr) indent_incr loop_blk + ^ "\n" ^ indent ^ "}" + | Error s -> indent ^ "ERROR(' " ^ s ^ "')" + + and block_to_string (env : fmt_env) (indent : string) (indent_incr : string) + (b : block) : string = + String.concat ";\n" + (List.map (statement_to_string env indent indent_incr) b.statements) +end + +module Ullbc = struct + open UllbcAst + + let rec statement_to_string (env : fmt_env) (indent : string) (st : statement) + : string = + statement_kind_to_string env indent st.kind + + and statement_kind_to_string (env : fmt_env) (indent : string) + (st : statement_kind) : string = + match st with + | Assign (p, rv) -> + indent ^ place_to_string env p ^ " := " ^ rvalue_to_string env rv + | SetDiscriminant (p, variant_id) -> + (* TODO: improve this to lookup the variant name by using the def id + (we are missing the def id here) *) + indent ^ "set_discriminant(" ^ place_to_string env p ^ ", " + ^ variant_id_to_pretty_string variant_id + ^ ")" + | Assert (asrt, abort_kind) -> + indent + ^ assertion_to_string env asrt + ^ " else " + ^ abort_kind_to_string env abort_kind + | StorageLive var_id -> + indent ^ "storage_live " ^ local_id_to_string env var_id + | StorageDead var_id -> + indent ^ "storage_dead " ^ local_id_to_string env var_id + | PlaceMention place -> indent ^ "_ := " ^ place_to_string env place + | CopyNonOverlapping { src; dst; count } -> + indent ^ "copy_non_overlapping(" ^ operand_to_string env src ^ ", " + ^ operand_to_string env dst ^ ", " + ^ operand_to_string env count + ^ ")" + | Nop -> "nop" + + let switch_to_string (indent : string) (tgt : switch) : string = + match tgt with + | If (b0, b1) -> + let b0 = block_id_to_string b0 in + let b1 = block_id_to_string b1 in + indent ^ "[true -> " ^ b0 ^ "; false -> " ^ b1 ^ "]" + | SwitchInt (_int_ty, branches, otherwise) -> + let branches = + List.map + (fun (sv, bid) -> + literal_to_string sv ^ " -> " ^ block_id_to_string bid ^ "; ") + branches + in + let branches = String.concat "" branches in + let otherwise = "_ -> " ^ block_id_to_string otherwise in + indent ^ "[" ^ branches ^ otherwise ^ "]" + + let rec terminator_to_string (env : fmt_env) (indent : string) + (st : terminator) : string = + terminator_kind_to_string env indent st.kind + + and terminator_kind_to_string (env : fmt_env) (indent : string) + (st : terminator_kind) : string = + match st with + | Goto bid -> indent ^ "goto " ^ block_id_to_string bid + | Switch (op, tgts) -> + indent ^ "switch " ^ operand_to_string env op + ^ switch_to_string indent tgts + | Call (call, tgt, unwind) -> + call_to_string env indent call + ^ " -> " ^ block_id_to_string tgt ^ "(unwind:" + ^ block_id_to_string unwind ^ ")" + | Drop (_, p, _, tgt, unwind) -> + indent ^ "drop " ^ place_to_string env p ^ " -> " + ^ block_id_to_string tgt ^ "(unwind:" ^ block_id_to_string unwind ^ ")" + | TAssert (asrt, tgt, unwind) -> + indent + ^ assertion_to_string env asrt + ^ " -> " ^ block_id_to_string tgt ^ "(unwind:" + ^ block_id_to_string unwind ^ ")" + | Abort _ -> indent ^ "panic" + | Return -> indent ^ "return" + | UnwindResume -> indent ^ "unwind_continue" + + let block_to_string (env : fmt_env) (indent : string) (indent_incr : string) + (id : BlockId.id) (block : block) : string = + let indent1 = indent ^ indent_incr in + let statements = + List.map + (fun st -> statement_to_string env indent1 st ^ ";\n") + block.statements + in + let terminator = terminator_to_string env indent1 block.terminator in + indent ^ block_id_to_string id ^ " {\n" + ^ String.concat "" statements + ^ terminator ^ ";\n" ^ indent ^ "}" + + let blocks_to_string (env : fmt_env) (indent : string) (indent_incr : string) + (blocks : block list) : string = + let blocks = BlockId.mapi (block_to_string env indent indent_incr) blocks in + String.concat "\n\n" blocks +end + +let fun_decl_to_string (env : fmt_env) (indent : string) (indent_incr : string) + (def : fun_decl) : string = + (* Locally update the environment *) + let env = fmt_env_replace_generics_and_preds env def.generics in + + let sg = def.signature in + + (* Function name *) + let name = name_to_string env def.item_meta.name in + + (* We print the declaration differently if it is opaque (no body) or transparent + * (we have access to a body) *) + let sg = bound_fun_sig_of_decl def in + match def.body with + | OpaqueBody + | ErrorBody _ + | MissingBody + | TraitMethodWithoutDefaultBody + | ExternBody _ + | IntrinsicBody _ + | TargetDispatchBody _ -> + let attrib = + match def.body with + | OpaqueBody -> "opaque" + | ErrorBody _ -> "error" + | TraitMethodWithoutDefaultBody -> "trait_method_without_default" + | MissingBody -> "missing" + | ExternBody name -> "extern(" ^ name ^ ")" + | IntrinsicBody (name, _) -> "intrinsic(" ^ name ^ ")" + | TargetDispatchBody targets -> + "target_dispatch(" + ^ String.concat ", " + (targets + |> List.map (fun (target, fdecl) -> + target ^ " => " ^ fun_decl_ref_to_string env fdecl)) + ^ ")" + | _ -> failwith "Impossible" + in + fun_sig_with_name_to_string env indent indent_incr (Some attrib) + (Some name) None sg + | StructuredBody { locals; _ } | UnstructuredBody { locals; _ } -> + (* Locally update the environment *) + let env_locals = List.map (fun v -> (v.index, v.name)) locals.locals in + let env = { env with locals = env_locals } in + + (* Arguments *) + let inputs = GAstUtils.locals_get_input_vars locals in + + (* All the locals (with erased regions) *) + let locals = locals_to_string env (indent ^ indent_incr) locals in + + (* Body *) + let body = + match def.body with + | StructuredBody { body; _ } -> + Llbc.block_to_string env (indent ^ indent_incr) indent_incr body + | UnstructuredBody { body; _ } -> + Ullbc.blocks_to_string env (indent ^ indent_incr) indent_incr body + | _ -> failwith "Impossible" + in + + (* Put everything together *) + fun_sig_with_name_to_string env indent indent_incr None (Some name) + (Some inputs) sg + ^ indent ^ "\n{\n" ^ locals ^ "\n\n" ^ body ^ "\n" ^ indent ^ "}" + +let crate_to_fmt_env (crate : crate) : fmt_env = + { crate; generics = []; locals = [] } + +let crate_to_string (m : crate) : string = + let env : fmt_env = crate_to_fmt_env m in + + (* The types *) + let type_decls = + List.map + (fun (_, d) -> type_decl_to_string env d) + (TypeDeclId.Map.bindings m.type_decls) + in + + (* The globals *) + let global_decls = + List.map + (fun (_, d) -> global_decl_to_string env "" " " d) + (GlobalDeclId.Map.bindings m.global_decls) + in + + (* The functions *) + let fun_decls = + List.map + (fun (_, d) -> fun_decl_to_string env "" " " d) + (FunDeclId.Map.bindings m.fun_decls) + in + + (* The trait declarations *) + let trait_decls = + List.map + (fun (_, d) -> trait_decl_to_string env "" " " d) + (TraitDeclId.Map.bindings m.trait_decls) + in + + (* The trait implementations *) + let trait_impls = + List.map + (fun (_, d) -> trait_impl_to_string env "" " " d) + (TraitImplId.Map.bindings m.trait_impls) + in + + (* Put everything together *) + let all_defs = + List.concat + [ type_decls; global_decls; trait_decls; trait_impls; fun_decls ] + in + String.concat "\n\n" all_defs diff --git a/charon-ml/src/PrintExpressions.ml b/charon-ml/src/PrintExpressions.ml deleted file mode 100644 index fb5490ca7..000000000 --- a/charon-ml/src/PrintExpressions.ml +++ /dev/null @@ -1,227 +0,0 @@ -(** Pretty-printing for expressions *) - -open Types -open Expressions -open LlbcAst -open PrintUtils -open PrintTypes - -let fun_decl_id_to_string = PrintTypes.fun_decl_id_to_string - -let local_id_to_pretty_string (id : local_id) : string = - "v@" ^ LocalId.to_string id - -let local_to_string (v : local) : string = - match v.name with - | None -> local_id_to_pretty_string v.index - | Some name -> name ^ "^" ^ LocalId.to_string v.index - -let local_id_to_string (env : 'a fmt_env) (id : LocalId.id) : string = - match List.find_opt (fun (i, _) -> i = id) env.locals with - | None -> local_id_to_pretty_string id - | Some (_, name) -> ( - match name with - | None -> local_id_to_pretty_string id - | Some name -> name ^ "^" ^ LocalId.to_string id) - -let (var_id_to_pretty_string - [@ocaml.alert deprecated "use [local_id_to_pretty_string] instead"]) = - local_id_to_pretty_string - -let (var_id_to_string - [@ocaml.alert deprecated "use [local_id_to_string] instead"]) = - local_id_to_string - -let (var_to_string [@ocaml.alert deprecated "use [local_to_string] instead"]) = - local_to_string - -let rec projection_elem_to_string (env : 'a fmt_env) (sub : string) - (pe : projection_elem) : string = - match pe with - | Deref -> "*(" ^ sub ^ ")" - | ProjIndex (off, from_end) -> - let idx_pre = if from_end then "-" else "" in - "(" ^ sub ^ ")[" ^ idx_pre ^ operand_to_string env off ^ "]" - | Subslice (from, to_, from_end) -> - let idx_pre = if from_end then "-" else "" in - "(" ^ sub ^ ")[" ^ idx_pre ^ operand_to_string env from ^ ".." - ^ operand_to_string env to_ ^ "]" - | Field (ProjTuple _, fid) -> "(" ^ sub ^ ")." ^ FieldId.to_string fid - | Field (ProjAdt (adt_id, opt_variant_id), fid) -> ( - let field_name = - match adt_field_to_string env adt_id opt_variant_id fid with - | Some field_name -> field_name - | None -> FieldId.to_string fid - in - match opt_variant_id with - | None -> "(" ^ sub ^ ")." ^ field_name - | Some variant_id -> - let variant_name = adt_variant_to_string env adt_id variant_id in - "(" ^ sub ^ " as " ^ variant_name ^ ")." ^ field_name) - | PtrMetadata -> sub ^ ".metadata" - -and place_to_string (env : 'a fmt_env) (p : place) : string = - match p.kind with - | PlaceLocal var_id -> local_id_to_string env var_id - | PlaceProjection (subplace, pe) -> - let subplace = place_to_string env subplace in - projection_elem_to_string env subplace pe - | PlaceGlobal global_ref -> - let generics = generic_args_to_string env global_ref.generics in - global_decl_id_to_string env global_ref.id ^ generics - -and cast_kind_to_string (env : 'a fmt_env) (cast : cast_kind) : string = - match cast with - | CastScalar (src, tgt) -> - "cast<" ^ literal_type_to_string src ^ "," ^ literal_type_to_string tgt - ^ ">" - | CastFnPtr (src, tgt) | CastRawPtr (src, tgt) | CastTransmute (src, tgt) -> - "cast<" ^ ty_to_string env src ^ "," ^ ty_to_string env tgt ^ ">" - | CastUnsize (src, tgt, _) -> - "unsize<" ^ ty_to_string env src ^ "," ^ ty_to_string env tgt ^ ">" - | CastConcretize (src, tgt) -> - "concretize<" ^ ty_to_string env src ^ "," ^ ty_to_string env tgt ^ ">" - -and nullop_to_string (env : 'a fmt_env) (op : nullop) : string = - match op with - | SizeOf -> "size_of" - | AlignOf -> "align_of" - | OffsetOf _ -> "offset_of(?)" - | UbChecks -> "ub_checks" - | ContractChecks -> "contract_checks" - | OverflowChecks -> "overflow_checks" - -and unop_to_string (env : 'a fmt_env) (unop : unop) : string = - match unop with - | Not -> "¬" - | Neg om -> overflow_mode_to_string om ^ ".-" - | Cast cast_kind -> cast_kind_to_string env cast_kind - -and overflow_mode_to_string (mode : overflow_mode) : string = - match mode with - | OWrap -> "wrap" - | OUB -> "ub" - | OPanic -> "panic" - -and binop_to_string (binop : binop) : string = - match binop with - | BitXor -> "^" - | BitAnd -> "&" - | BitOr -> "|" - | Eq -> "==" - | Lt -> "<" - | Le -> "<=" - | Ne -> "!=" - | Ge -> ">=" - | Gt -> ">" - | Div om -> overflow_mode_to_string om ^ "./" - | Rem om -> overflow_mode_to_string om ^ ".%" - | Add om -> overflow_mode_to_string om ^ ".+" - | Sub om -> overflow_mode_to_string om ^ ".-" - | Mul om -> overflow_mode_to_string om ^ ".*" - | Shl om -> overflow_mode_to_string om ^ ".<<" - | Shr om -> overflow_mode_to_string om ^ ".>>" - | AddChecked -> "checked.+" - | SubChecked -> "checked.-" - | MulChecked -> "checked.*" - | Cmp -> "cmp" - | Offset -> "offset" - -and operand_to_string (env : 'a fmt_env) (op : operand) : string = - match op with - | Copy p -> "copy " ^ place_to_string env p - | Move p -> "move " ^ place_to_string env p - | Constant cv -> constant_expr_to_string env cv - -and aggregate_to_string (env : 'a fmt_env) (agg : aggregate_kind) - (fields : operand list) : string = - let fields = List.map (operand_to_string env) fields in - match agg with - | AggregatedAdt (tref, opt_variant_id, opt_field_id) -> ( - match tref.id with - | TTuple -> "(" ^ String.concat ", " fields ^ ")" - | TAdtId def_id -> - let adt_name = type_decl_id_to_string env def_id in - let variant_name = - match opt_variant_id with - | None -> adt_name - | Some variant_id -> - adt_name ^ "::" ^ adt_variant_to_string env def_id variant_id - in - let fields = - match adt_field_names env def_id opt_variant_id with - | None -> "(" ^ String.concat ", " fields ^ ")" - | Some field_names -> - let field_names = - match opt_field_id with - | None -> field_names - (* Only keep the selected field *) - | Some field_id -> - [ List.nth field_names (FieldId.to_int field_id) ] - in - let fields = List.combine field_names fields in - let fields = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - fields - in - let fields = String.concat " " fields in - "{ " ^ fields ^ " }" - in - variant_name ^ " " ^ fields - | TBuiltin _ -> raise (Failure "Unreachable")) - | AggregatedArray (_ty, _cg) -> "[" ^ String.concat ", " fields ^ "]" - | AggregatedRawPtr (_, refk) -> - let refk = - match refk with - | RShared -> "&raw const" - | RMut -> "&raw mut" - in - refk ^ " (" ^ String.concat ", " fields ^ ")" - -and rvalue_to_string (env : 'a fmt_env) (rv : rvalue) : string = - match rv with - | Use op -> operand_to_string env op - | RvRef (p, bk, op) -> begin - let op = operand_to_string env op in - let p = place_to_string env p in - match bk with - | BShared -> "&(" ^ p ^ ", " ^ op ^ ")" - | BMut -> "&mut (" ^ p ^ ", " ^ op ^ ")" - | BTwoPhaseMut -> "&two-phase (" ^ p ^ ", " ^ op ^ ")" - | BUniqueImmutable -> "&uniq (" ^ p ^ ", " ^ op ^ ")" - | BShallow -> "&shallow (" ^ p ^ ", " ^ op ^ ")" - end - | RawPtr (p, pk, op) -> begin - let op = operand_to_string env op in - let p = place_to_string env p in - match pk with - | RShared -> "&raw const (" ^ p ^ ", " ^ op ^ ")" - | RMut -> "&raw mut (" ^ p ^ ", " ^ op ^ ")" - end - | NullaryOp (op, ty) -> - nullop_to_string env op ^ "<" ^ ty_to_string env ty ^ ">" - | UnaryOp (unop, op) -> - unop_to_string env unop ^ " " ^ operand_to_string env op - | BinaryOp (binop, op1, op2) -> - operand_to_string env op1 ^ " " ^ binop_to_string binop ^ " " - ^ operand_to_string env op2 - | Discriminant p -> "discriminant(" ^ place_to_string env p ^ ")" - | Len (place, ty, const_generics) -> - let const_generics = - match const_generics with - | None -> [] - | Some cg -> [ cg ] - in - "len<" - ^ String.concat ", " - (ty_to_string env ty - :: List.map (constant_expr_to_string env) const_generics) - ^ ">(" ^ place_to_string env place ^ ")" - | Repeat (v, _, len) -> - "[" ^ operand_to_string env v ^ ";" - ^ constant_expr_to_string env len - ^ "]" - | ShallowInitBox (op, _) -> - "shallow-init-box(" ^ operand_to_string env op ^ ")" - | Aggregate (akind, ops) -> aggregate_to_string env akind ops diff --git a/charon-ml/src/PrintGAst.ml b/charon-ml/src/PrintGAst.ml deleted file mode 100644 index 6e47251d3..000000000 --- a/charon-ml/src/PrintGAst.ml +++ /dev/null @@ -1,306 +0,0 @@ -(** Pretty-printing for generic AST (ULLBC and LLBC) *) - -open Types -open TypesUtils -open GAst -open GAstUtils -open PrintUtils -open PrintTypes -open PrintExpressions - -let item_id_to_string (id : item_id) : string = - match id with - | IdFun id -> FunDeclId.to_string id - | IdGlobal id -> GlobalDeclId.to_string id - | IdType id -> TypeDeclId.to_string id - | IdTraitDecl id -> TraitDeclId.to_string id - | IdTraitImpl id -> TraitImplId.to_string id - -let fn_operand_to_string (env : 'a fmt_env) (op : fn_operand) : string = - match op with - | FnOpRegular func -> fn_ptr_to_string env func - | FnOpDynamic op -> "(" ^ operand_to_string env op ^ ")" - -let call_to_string (env : 'a fmt_env) (indent : string) (call : call) : string = - let func = fn_operand_to_string env call.func in - let args = List.map (operand_to_string env) call.args in - let args = "(" ^ String.concat ", " args ^ ")" in - let dest = place_to_string env call.dest in - indent ^ dest ^ " := move " ^ func ^ args - -let assertion_to_string (env : 'a fmt_env) (a : assertion) : string = - let cond = operand_to_string env a.cond in - if a.expected then "assert(" ^ cond ^ ")" else "assert(¬" ^ cond ^ ")" - -let abort_kind_to_string (env : 'a fmt_env) (a : abort_kind) : string = - match a with - | Panic None -> "panic" - | Panic (Some name) -> "panic(" ^ name_to_string env name ^ ")" - | UndefinedBehavior -> "undefined_behavior" - | UnwindTerminate -> "unwind_terminate" - -(** Small helper *) -let fun_sig_with_name_to_string (env : 'a fmt_env) (indent : string) - (indent_incr : string) (attribute : string option) (name : string option) - (args : local list option) (sg : bound_fun_sig) : string = - let { item_binder_params = generics; item_binder_value = sg; _ } = sg in - let env = fmt_env_replace_generics_and_preds env generics in - let ty_to_string = ty_to_string env in - - (* Unsafe keyword *) - let unsafe = if sg.is_unsafe then "unsafe " else "" in - - (* Generics and predicates *) - let params, clauses = - predicates_and_trait_clauses_to_string env indent indent_incr generics - in - let params = - if params = [] then "" else "<" ^ String.concat ", " params ^ ">" - in - - (* Return type *) - let ret_ty = sg.output in - let ret_ty = if ty_is_unit ret_ty then "" else " -> " ^ ty_to_string ret_ty in - - (* Arguments *) - let args = - match args with - | None -> - let args = List.map ty_to_string sg.inputs in - String.concat ", " args - | Some args -> - let args = List.combine args sg.inputs in - let args = - List.map - (fun (var, rty) -> local_to_string var ^ " : " ^ ty_to_string rty) - args - in - String.concat ", " args - in - - (* Put everything together *) - let attribute = - match attribute with - | None -> "" - | Some attr -> attr ^ " " - in - let name = - match name with - | None -> "" - | Some name -> " " ^ name - in - indent ^ attribute ^ unsafe ^ "fn" ^ name ^ params ^ "(" ^ args ^ ")" ^ ret_ty - ^ clauses - -let fun_sig_to_string (env : 'a fmt_env) (indent : string) - (indent_incr : string) (sg : fun_sig item_binder) : string = - fun_sig_with_name_to_string env indent indent_incr None None None sg - -let gfun_decl_to_string (env : 'a fmt_env) (indent : string) - (indent_incr : string) - (body_to_string : 'a fmt_env -> string -> string -> 'body -> string) - (def : 'body gfun_decl) : string = - (* Locally update the environment *) - let env = fmt_env_replace_generics_and_preds env def.generics in - - let sg = def.signature in - - (* Function name *) - let name = name_to_string env def.item_meta.name in - - (* We print the declaration differently if it is opaque (no body) or transparent - * (we have access to a body) *) - let sg = bound_fun_sig_of_decl def in - match def.body with - | Opaque -> - fun_sig_with_name_to_string env indent indent_incr (Some "opaque") - (Some name) None sg - | Missing -> - fun_sig_with_name_to_string env indent indent_incr (Some "missing") - (Some name) None sg - | TraitMethodWithoutDefault -> - fun_sig_with_name_to_string env indent indent_incr - (Some "method_without_default_body") (Some name) None sg - | Extern sym -> - fun_sig_with_name_to_string env indent indent_incr - (Some ("extern:" ^ sym)) - (Some name) None sg - | Intrinsic { name; _ } -> - fun_sig_with_name_to_string env indent indent_incr - (Some ("intrinsic:" ^ name)) - (Some name) None sg - | TargetDispatch targets -> - let targets = - targets - |> List.map (fun (tgt, fref) -> - tgt ^ " => " ^ fun_decl_ref_to_string env fref) - |> String.concat "," - in - fun_sig_with_name_to_string env indent indent_incr - (Some ("target_dispatch(" ^ targets ^ ")")) - (Some name) None sg - | Error err -> - fun_sig_with_name_to_string env indent indent_incr - (Some ("error(\"" ^ err.msg ^ "\")")) - (Some name) None sg - | Body body -> - (* Locally update the environment *) - let locals = List.map (fun v -> (v.index, v.name)) body.locals.locals in - let env = { env with locals } in - - (* Arguments *) - let inputs = GAstUtils.locals_get_input_vars body.locals in - - (* All the locals (with erased regions) *) - let locals = - List.map - (fun var -> - indent ^ indent_incr ^ local_to_string var ^ " : " - ^ ty_to_string env var.local_ty - ^ ";") - body.locals.locals - in - let locals = String.concat "\n" locals in - - (* Body *) - let body = - body_to_string env (indent ^ indent_incr) indent_incr body.body - in - - (* Put everything together *) - fun_sig_with_name_to_string env indent indent_incr None (Some name) - (Some inputs) sg - ^ indent ^ "\n{\n" ^ locals ^ "\n\n" ^ body ^ "\n" ^ indent ^ "}" - -let trait_decl_to_string (env : 'a fmt_env) (indent : string) - (indent_incr : string) (def : trait_decl) : string = - (* Locally update the environment *) - let env = fmt_env_replace_generics_and_preds env def.generics in - - let ty_to_string = ty_to_string env in - - (* Name *) - let name = name_to_string env def.item_meta.name in - - (* Generics and predicates *) - let params, clauses = - predicates_and_trait_clauses_to_string env indent indent_incr def.generics - in - let params = - if params = [] then "" else "<" ^ String.concat ", " params ^ ">" - in - - let indent1 = indent ^ indent_incr in - - let items = - let parent_clauses = - List.map - (fun clause -> - indent1 ^ "parent_clause_" - ^ TraitClauseId.to_string clause.clause_id - ^ " : " - ^ trait_param_to_string env clause - ^ "\n") - def.implied_clauses - in - let consts = - List.map - (fun c -> - let ty = ty_to_string c.ty in - indent1 ^ "const " ^ c.name ^ " : " ^ ty ^ "\n") - def.consts - in - let types = - List.map - (fun (bound_ty : trait_assoc_ty binder) -> - let env = - fmt_env_push_generics_and_preds env bound_ty.binder_params - in - (* TODO: print clauses too *) - let params, _clauses = - predicates_and_trait_clauses_to_string env "" " " def.generics - in - let params = - if params <> [] then "<" ^ String.concat ", " params ^ ">" else "" - in - indent1 ^ "type " ^ bound_ty.binder_value.name ^ params ^ "\n") - def.types - in - let methods = - List.map - (fun (m : trait_method binder) -> - indent1 ^ "fn " ^ m.binder_value.name ^ " : " - ^ fun_decl_id_to_string env m.binder_value.item.id - ^ "\n") - def.methods - in - let items = List.concat [ parent_clauses; consts; types; methods ] in - if items = [] then "" else "\n{\n" ^ String.concat "" items ^ "}" - in - - "trait " ^ name ^ params ^ clauses ^ items - -let trait_impl_to_string (env : 'a fmt_env) (indent : string) - (indent_incr : string) (def : trait_impl) : string = - (* Locally update the environment *) - let env = fmt_env_replace_generics_and_preds env def.generics in - - (* Name *) - let name = name_to_string env def.item_meta.name in - - (* Generics and predicates *) - let params, clauses = - predicates_and_trait_clauses_to_string env indent indent_incr def.generics - in - let params = - if params = [] then "" else "<" ^ String.concat ", " params ^ ">" - in - - let indent1 = indent ^ indent_incr in - - let items = - (* The parent clauses are given by the trait refs of the implemented trait *) - let parent_clauses = - Collections.List.mapi - (fun i trait_ref -> - indent1 ^ "parent_clause" ^ string_of_int i ^ " = " - ^ trait_ref_to_string env trait_ref - ^ "\n") - def.implied_trait_refs - in - let consts = - List.map - (fun (name, gref) -> - let gref = global_decl_ref_to_string env gref in - indent1 ^ "const " ^ name ^ " = " ^ gref ^ "\n") - def.consts - in - let types = - List.map - (fun (name, bound_ty) -> - let env = - fmt_env_push_generics_and_preds env bound_ty.binder_params - in - let params, _clauses = - predicates_and_trait_clauses_to_string env "" " " def.generics - in - let params = - if params <> [] then "<" ^ String.concat ", " params ^ ">" else "" - in - indent1 ^ "type " ^ name ^ params ^ " = " - ^ ty_to_string env bound_ty.binder_value.value - ^ "\n") - def.types - in - let env_method ((name, f) : _ * fun_decl_ref binder) = - indent1 ^ "fn " ^ name ^ " : " - ^ fun_decl_id_to_string env f.binder_value.id - ^ "\n" - in - let methods = List.map env_method def.methods in - let items = List.concat [ parent_clauses; consts; types; methods ] in - if items = [] then "" else "\n{\n" ^ String.concat "" items ^ "}" - in - - let impl_trait = trait_decl_ref_to_string env def.impl_trait in - "impl" ^ params ^ " " ^ name ^ params ^ " : " ^ impl_trait ^ clauses ^ items diff --git a/charon-ml/src/PrintLlbcAst.ml b/charon-ml/src/PrintLlbcAst.ml deleted file mode 100644 index b8c6c1cda..000000000 --- a/charon-ml/src/PrintLlbcAst.ml +++ /dev/null @@ -1,214 +0,0 @@ -open PrintUtils -open Types -open TypesUtils -open LlbcAst -open PrintTypes -open PrintValues -open PrintExpressions - -type fmt_env = block PrintUtils.fmt_env - -(** Pretty-printing for LLBC AST (generic functions) *) -module Ast = struct - include PrintGAst - - let rec statement_to_string (env : fmt_env) (indent : string) - (indent_incr : string) (st : statement) : string = - statement_kind_to_string env indent indent_incr st.kind - - and statement_kind_to_string (env : fmt_env) (indent : string) - (indent_incr : string) (st : statement_kind) : string = - match st with - | Assign (p, rv) -> - indent ^ place_to_string env p ^ " := " ^ rvalue_to_string env rv - | SetDiscriminant (p, variant_id) -> - (* TODO: improve this to lookup the variant name by using the def id *) - indent ^ "set_discriminant(" ^ place_to_string env p ^ ", " - ^ VariantId.to_string variant_id - ^ ")" - | CopyNonOverlapping { src; dst; count } -> - indent ^ "copy_non_overlapping(" ^ operand_to_string env src ^ ", " - ^ operand_to_string env dst ^ ", " - ^ operand_to_string env count - ^ ")" - | StorageLive var_id -> - indent ^ "storage_live " ^ local_id_to_string env var_id - | StorageDead var_id -> - indent ^ "storage_dead " ^ local_id_to_string env var_id - | PlaceMention place -> indent ^ "_ := " ^ place_to_string env place - | Drop (p, _, _) -> indent ^ "drop " ^ place_to_string env p - | Assert (asrt, abort_kind) -> - indent - ^ assertion_to_string env asrt - ^ " else " - ^ abort_kind_to_string env abort_kind - | Call call -> call_to_string env indent call - | Abort (Panic _) -> indent ^ "panic" - | Abort UndefinedBehavior -> indent ^ "undefined_behavior" - | Abort UnwindTerminate -> indent ^ "unwind_terminate" - | Return -> indent ^ "return" - | Break i -> indent ^ "break " ^ string_of_int i - | Continue i -> indent ^ "continue " ^ string_of_int i - | Nop -> indent ^ "nop" - | Switch switch -> ( - match switch with - | If (op, true_st, false_st) -> - let op = operand_to_string env op in - let inner_indent = indent ^ indent_incr in - let inner_to_string = - block_to_string env inner_indent indent_incr - in - let true_st = inner_to_string true_st in - let false_st = inner_to_string false_st in - indent ^ "if (" ^ op ^ ") {\n" ^ true_st ^ "\n" ^ indent ^ "}\n" - ^ indent ^ "else {\n" ^ false_st ^ "\n" ^ indent ^ "}" - | SwitchInt (op, _ty, branches, otherwise) -> - let op = operand_to_string env op in - let indent1 = indent ^ indent_incr in - let indent2 = indent1 ^ indent_incr in - let inner_to_string2 = block_to_string env indent2 indent_incr in - let branches = - List.map - (fun (svl, be) -> - let svl = - List.map (fun sv -> "| " ^ literal_to_string sv) svl - in - let svl = String.concat " " svl in - indent ^ svl ^ " => {\n" ^ inner_to_string2 be ^ "\n" - ^ indent1 ^ "}") - branches - in - let branches = String.concat "\n" branches in - let branches = - branches ^ "\n" ^ indent1 ^ "_ => {\n" - ^ inner_to_string2 otherwise ^ "\n" ^ indent1 ^ "}" - in - indent ^ "switch (" ^ op ^ ") {\n" ^ branches ^ "\n" ^ indent ^ "}" - | Match (p, branches, otherwise) -> - let p = place_to_string env p in - let indent1 = indent ^ indent_incr in - let indent2 = indent1 ^ indent_incr in - let inner_to_string2 = block_to_string env indent2 indent_incr in - let branches = - List.map - (fun (svl, be) -> - let svl = - List.map (fun sv -> "| " ^ VariantId.to_string sv) svl - in - let svl = String.concat " " svl in - indent ^ svl ^ " => {\n" ^ inner_to_string2 be ^ "\n" - ^ indent1 ^ "}") - branches - in - let branches = String.concat "\n" branches in - let otherwise = - match otherwise with - | None -> "" - | Some otherwise -> - "\n" ^ indent1 ^ "_ => {\n" ^ inner_to_string2 otherwise - ^ "\n" ^ indent1 ^ "}" - in - let branches = branches ^ otherwise in - indent ^ "match (" ^ p ^ ") {\n" ^ branches ^ "\n" ^ indent ^ "}") - | Loop loop_blk -> - indent ^ "loop {\n" - ^ block_to_string env (indent ^ indent_incr) indent_incr loop_blk - ^ "\n" ^ indent ^ "}" - | Error s -> indent ^ "ERROR(' " ^ s ^ "')" - - and block_to_string (env : fmt_env) (indent : string) (indent_incr : string) - (b : block) : string = - String.concat ";\n" - (List.map (statement_to_string env indent indent_incr) b.statements) - - let fun_sig_to_string = fun_sig_to_string - - let fun_decl_to_string (env : fmt_env) (indent : string) - (indent_incr : string) (def : fun_decl) : string = - gfun_decl_to_string env indent indent_incr block_to_string def - - let global_decl_to_string (env : fmt_env) (indent : string) - (_indent_incr : string) (def : global_decl) : string = - (* Locally update the generics and the predicates *) - let env = fmt_env_replace_generics_and_preds env def.generics in - let params, clauses = - predicates_and_trait_clauses_to_string env "" " " def.generics - in - let params = - if params <> [] then "<" ^ String.concat ", " params ^ ">" else "" - in - - (* Global name *) - let name = name_to_string env def.item_meta.name in - - (* Type *) - let ty = ty_to_string env def.ty in - - let body_id = fun_decl_id_to_string env def.init in - indent ^ "global " ^ name ^ params ^ clauses ^ " : " ^ ty ^ " = " ^ body_id -end - -(** Pretty-printing for ASTs (functions based on a declaration context) *) -module Crate = struct - open Ast - - let crate_to_fmt_env (crate : crate) : fmt_env = - { crate; generics = []; locals = [] } - - let crate_fun_decl_to_string (m : crate) (d : fun_decl) : string = - let env = crate_to_fmt_env m in - fun_decl_to_string env "" " " d - - let crate_type_decl_id_to_string (m : crate) (id : type_decl_id) : string = - let env = crate_to_fmt_env m in - type_decl_id_to_string env id - - let crate_name_to_string (m : crate) (x : name) : string = - let env = crate_to_fmt_env m in - name_to_string env x - - let crate_to_string (m : crate) : string = - let env = crate_to_fmt_env m in - - (* The types *) - let type_decls = - List.map - (fun (_, d) -> type_decl_to_string env d) - (TypeDeclId.Map.bindings m.type_decls) - in - - (* The globals *) - let global_decls = - List.map - (fun (_, d) -> global_decl_to_string env "" " " d) - (GlobalDeclId.Map.bindings m.global_decls) - in - - (* The functions *) - let fun_decls = - List.map - (fun (_, d) -> fun_decl_to_string env "" " " d) - (FunDeclId.Map.bindings m.fun_decls) - in - - (* The trait declarations *) - let trait_decls = - List.map - (fun (_, d) -> trait_decl_to_string env "" " " d) - (TraitDeclId.Map.bindings m.trait_decls) - in - - (* The trait implementations *) - let trait_impls = - List.map - (fun (_, d) -> trait_impl_to_string env "" " " d) - (TraitImplId.Map.bindings m.trait_impls) - in - - (* Put everything together *) - let all_defs = - List.concat - [ type_decls; global_decls; trait_decls; trait_impls; fun_decls ] - in - String.concat "\n\n" all_defs -end diff --git a/charon-ml/src/PrintTypes.ml b/charon-ml/src/PrintTypes.ml deleted file mode 100644 index 010b05ef5..000000000 --- a/charon-ml/src/PrintTypes.ml +++ /dev/null @@ -1,657 +0,0 @@ -(** Pretty-printing for types *) - -include PrintValues -open Meta -open Types -open TypesUtils -open GAst -open PrintUtils - -let region_param_to_string (rv : region_param) : string = - match rv.name with - | Some name -> name - | None -> RegionId.to_string rv.index - -let g_region_group_to_string (rid_to_string : 'rid -> string) - (id_to_string : 'id -> string) (gr : ('rid, 'id) g_region_group) : string = - let { id; regions; parents } = gr in - "{ id: " ^ id_to_string id ^ "; regions: [" - ^ String.concat ", " (List.map rid_to_string regions) - ^ "]; parents: [" - ^ String.concat ", " (List.map id_to_string parents) - ^ "] }" - -let region_var_group_to_string (gr : region_var_group) : string = - g_region_group_to_string RegionId.to_string RegionGroupId.to_string gr - -let region_var_groups_to_string (gl : region_var_groups) : string = - String.concat "\n" (List.map region_var_group_to_string gl) - -let ref_kind_to_string (rk : ref_kind) : string = - match rk with - | RMut -> "Mut" - | RShared -> "Shared" - -let builtin_ty_to_string (_ : builtin_ty) : string = "Box" - -let de_bruijn_var_to_pretty_string show_varid var : string = - match var with - | Bound (dbid, varid) -> show_de_bruijn_id dbid ^ "_" ^ show_varid varid - | Free varid -> show_varid varid - -let region_db_var_to_pretty_string (var : region_db_var) : string = - "'" ^ de_bruijn_var_to_pretty_string RegionId.to_string var - -let type_db_var_to_pretty_string (var : type_db_var) : string = - "T@" ^ de_bruijn_var_to_pretty_string TypeVarId.to_string var - -let type_var_id_to_pretty_string (id : type_var_id) : string = - "T@" ^ TypeVarId.to_string id - -let type_param_to_string (tv : type_param) : string = tv.name - -let const_generic_var_id_to_pretty_string (id : const_generic_var_id) : string = - "C@" ^ ConstGenericVarId.to_string id - -let const_generic_db_var_to_pretty_string (var : const_generic_db_var) : string - = - "C@" ^ de_bruijn_var_to_pretty_string ConstGenericVarId.to_string var - -let const_generic_param_to_string (v : const_generic_param) : string = v.name - -let trait_clause_id_to_pretty_string (id : trait_clause_id) : string = - "TraitClause@" ^ TraitClauseId.to_string id - -let trait_db_var_to_pretty_string (var : trait_db_var) : string = - "TraitClause@" ^ de_bruijn_var_to_pretty_string TraitClauseId.to_string var - -let trait_clause_id_to_string _ id = trait_clause_id_to_pretty_string id - -let type_decl_id_to_pretty_string (id : type_decl_id) : string = - "TypeDecl@" ^ TypeDeclId.to_string id - -let fun_decl_id_to_pretty_string (id : FunDeclId.id) : string = - "FunDecl@" ^ FunDeclId.to_string id - -let global_decl_id_to_pretty_string (id : GlobalDeclId.id) : string = - "GlobalDecl@" ^ GlobalDeclId.to_string id - -let trait_decl_id_to_pretty_string (id : trait_decl_id) : string = - "TraitDecl@" ^ TraitDeclId.to_string id - -let trait_impl_id_to_pretty_string (id : trait_impl_id) : string = - "TraitImpl@" ^ TraitImplId.to_string id - -let variant_id_to_pretty_string (id : variant_id) : string = - "Variant@" ^ VariantId.to_string id - -let field_id_to_pretty_string (id : field_id) : string = - "Field@" ^ FieldId.to_string id - -let lookup_var_in_env (env : 'a fmt_env) - (find_in : generic_params -> 'id -> 'b option) (var : 'id de_bruijn_var) : - 'b option = - if List.length env.generics == 0 then None - else - let dbid, varid = - match var with - | Bound (dbid, varid) -> (dbid, varid) - | Free varid -> - let len = List.length env.generics in - let dbid = len - 1 in - (dbid, varid) - in - match List.nth_opt env.generics dbid with - | None -> None - | Some generics -> begin - match find_in generics varid with - | None -> None - | Some r -> Some r - end - -let region_db_var_to_string (env : 'a fmt_env) (var : region_db_var) : string = - (* Note that the regions are not necessarily ordered following their indices *) - let find (generics : generic_params) varid = - List.find_opt (fun (v : region_param) -> v.index = varid) generics.regions - in - match lookup_var_in_env env find var with - | None -> region_db_var_to_pretty_string var - | Some r -> region_param_to_string r - -let type_db_var_to_string (env : 'a fmt_env) (var : type_db_var) : string = - let find (generics : generic_params) varid = - List.find_opt (fun (v : type_param) -> v.index = varid) generics.types - in - match lookup_var_in_env env find var with - | None -> type_db_var_to_pretty_string var - | Some r -> type_param_to_string r - -let const_generic_db_var_to_string (env : 'a fmt_env) - (var : const_generic_db_var) : string = - let find (generics : generic_params) varid = - List.find_opt - (fun (v : const_generic_param) -> v.index = varid) - generics.const_generics - in - match lookup_var_in_env env find var with - | None -> const_generic_db_var_to_pretty_string var - | Some r -> const_generic_param_to_string r - -let trait_db_var_to_string (env : 'a fmt_env) (var : trait_db_var) : string = - let find (generics : generic_params) varid = - List.find_opt - (fun (v : trait_param) -> v.clause_id = varid) - generics.trait_clauses - in - match lookup_var_in_env env find var with - | None -> trait_db_var_to_pretty_string var - | Some r -> trait_clause_id_to_pretty_string r.clause_id - -let region_to_string (env : 'a fmt_env) (r : region) : string = - match r with - | RStatic -> "'static" - | RErased -> "'_" - | RBody id -> "°" ^ RegionId.to_string id - | RVar var -> region_db_var_to_string env var - -let region_binder_to_string (value_to_string : 'a fmt_env -> 'c -> string) - (env : 'a fmt_env) (rb : 'c region_binder) : string = - let env = fmt_env_push_regions env rb.binder_regions in - let value = value_to_string env rb.binder_value in - match rb.binder_regions with - | [] -> value - | _ -> - "for <" - ^ String.concat "," (List.map region_param_to_string rb.binder_regions) - ^ "> " ^ value - -let rec type_id_to_string (env : 'a fmt_env) (id : type_id) : string = - match id with - | TAdtId id -> type_decl_id_to_string env id - | TTuple -> "" - | TBuiltin aty -> ( - match aty with - | TBox -> "alloc::boxed::Box" - | TStr -> "str") - -and type_decl_id_to_string env def_id = - (* We don't want the printing functions to crash if the crate is partial *) - match TypeDeclId.Map.find_opt def_id env.crate.type_decls with - | None -> type_decl_id_to_pretty_string def_id - | Some def -> name_to_string env def.item_meta.name - -and type_decl_ref_to_string (env : 'a fmt_env) (tref : type_decl_ref) : string = - match tref.id with - | TTuple -> - let params, trait_refs = generic_args_to_strings env tref.generics in - "(" ^ String.concat ", " params ^ ")" - | id -> - let id = type_id_to_string env id in - let generics = generic_args_to_string env tref.generics in - id ^ generics - -and fun_decl_id_to_string (env : 'a fmt_env) (id : FunDeclId.id) : string = - match FunDeclId.Map.find_opt id env.crate.fun_decls with - | None -> fun_decl_id_to_pretty_string id - | Some def -> name_to_string env def.item_meta.name - -and fun_decl_ref_to_string (env : 'a fmt_env) (fn : fun_decl_ref) : string = - let fun_id = fun_decl_id_to_string env fn.id in - let generics = generic_args_to_string env fn.generics in - fun_id ^ generics - -and global_decl_id_to_string env def_id = - match GlobalDeclId.Map.find_opt def_id env.crate.global_decls with - | None -> global_decl_id_to_pretty_string def_id - | Some def -> name_to_string env def.item_meta.name - -and global_decl_ref_to_string (env : 'a fmt_env) (gr : global_decl_ref) : string - = - let global_id = global_decl_id_to_string env gr.id in - let generics = generic_args_to_string env gr.generics in - global_id ^ generics - -and trait_decl_id_to_string env id = - match TraitDeclId.Map.find_opt id env.crate.trait_decls with - | None -> trait_decl_id_to_pretty_string id - | Some def -> name_to_string env def.item_meta.name - -and trait_impl_id_to_string env id = - match TraitImplId.Map.find_opt id env.crate.trait_impls with - | None -> trait_impl_id_to_pretty_string id - | Some def -> name_to_string env def.item_meta.name - -and trait_impl_ref_to_string (env : 'a fmt_env) (iref : trait_impl_ref) : string - = - let impl = trait_impl_id_to_string env iref.id in - let generics = generic_args_to_string env iref.generics in - impl ^ generics - -and provenance_to_string (env : 'a fmt_env) (pv : provenance) : string = - match pv with - | ProvGlobal gref -> "prov_global(" ^ global_decl_ref_to_string env gref ^ ")" - | ProvFunction fn_ref -> "prov_fn(" ^ fun_decl_ref_to_string env fn_ref ^ ")" - | ProvUnknown -> "prov_unknown" - -and byte_to_string (env : 'a fmt_env) (cv : byte) : string = - match cv with - | Uninit -> "uninit" - | Value b -> string_of_int b - | Provenance (p, i) -> - provenance_to_string env p ^ "[" ^ string_of_int i ^ "]" - -and const_aggregate_to_string (env : 'a fmt_env) (tref : type_decl_ref) - opt_variant_id (fields : constant_expr list) : string = - let fields = List.map (constant_expr_to_string env) fields in - - match tref.id with - | TTuple -> "(" ^ String.concat ", " fields ^ ")" - | TAdtId def_id -> - let adt_name = type_decl_id_to_string env def_id in - let variant_name = - match opt_variant_id with - | None -> adt_name - | Some variant_id -> - adt_name ^ "::" ^ adt_variant_to_string env def_id variant_id - in - let fields = - match adt_field_names env def_id opt_variant_id with - | None -> "(" ^ String.concat ", " fields ^ ")" - | Some field_names -> - let fields = List.combine field_names fields in - let fields = - List.map - (fun (field, value) -> field ^ " = " ^ value ^ ";") - fields - in - let fields = String.concat " " fields in - "{ " ^ fields ^ " }" - in - variant_name ^ " " ^ fields - | TBuiltin _ -> raise (Failure "Unreachable") - -and constant_expr_to_string (env : 'a fmt_env) (cv : constant_expr) : string = - match cv.kind with - | CLiteral lit -> literal_to_string lit - | CVar var -> const_generic_db_var_to_string env var - | CTraitConst (trait_ref, const_name) -> - let trait_ref = trait_ref_to_string env trait_ref in - trait_ref ^ const_name - | CVTableRef trait_ref -> - let trait_ref = trait_ref_to_string env trait_ref in - "&vtable_of(" ^ trait_ref ^ ")" - | CFnDef fn_ptr | CFnPtr fn_ptr -> fn_ptr_to_string env fn_ptr - | CRawMemory bytes -> - "RawMemory([" - ^ String.concat ", " (List.map (byte_to_string env) bytes) - ^ "])" - | COpaque reason -> "Opaque(" ^ reason ^ ")" - | CAdt (variant_id, fields) -> begin - match cv.ty with - | TAdt tref -> const_aggregate_to_string env tref variant_id fields - | _ -> "malformed constant" - end - | CArray fields -> - "[" - ^ String.concat ", " (List.map (constant_expr_to_string env) fields) - ^ "]" - | CGlobal gref -> global_decl_ref_to_string env gref - | CPtrNoProvenance n -> "(" ^ Z.to_string n ^ " as *const _)" - | CRef (c, _) -> "&" ^ constant_expr_to_string env c - | CPtr (ref_kind, c, _) -> - let ref_kind = - match ref_kind with - | RShared -> "&raw const" - | RMut -> "&raw mut" - in - ref_kind ^ constant_expr_to_string env c - -and builtin_fun_id_to_string (aid : builtin_fun_id) : string = - match aid with - | BoxNew -> "alloc::boxed::Box::new" - | ArrayToSliceShared -> "@ArrayToSliceShared" - | ArrayToSliceMut -> "@ArrayToSliceMut" - | ArrayRepeat -> "@ArrayRepeat" - | Index { is_array; mutability; is_range } -> - let ty = if is_array then "Array" else "Slice" in - let op = if is_range then "SubSlice" else "Index" in - let mutability = ref_kind_to_string mutability in - "@" ^ ty ^ op ^ mutability - | PtrFromParts mut -> - let mut = if mut = RMut then "Mut" else "" in - "@PtrFromParts" ^ mut - -and fun_id_to_string (env : 'a fmt_env) (fid : fun_id) : string = - match fid with - | FRegular fid -> fun_decl_id_to_string env fid - | FBuiltin aid -> builtin_fun_id_to_string aid - -and fn_ptr_kind_to_string (env : 'a fmt_env) (r : fn_ptr_kind) : string = - match r with - | TraitMethod (trait_ref, method_name, _) -> - trait_ref_to_string env trait_ref ^ "::" ^ method_name - | FunId fid -> fun_id_to_string env fid - -and fn_ptr_to_string (env : 'a fmt_env) (ptr : fn_ptr) : string = - let generics = generic_args_to_string env ptr.generics in - fn_ptr_kind_to_string env ptr.kind ^ generics - -and ty_to_string (env : 'a fmt_env) (ty : ty) : string = - match ty with - | TAdt tref -> type_decl_ref_to_string env tref - | TVar tv -> type_db_var_to_string env tv - | TNever -> "!" - | TLiteral lit_ty -> literal_type_to_string lit_ty - | TTraitType (trait_ref, type_name) -> - let trait_ref = trait_ref_to_string env trait_ref in - trait_ref ^ "::" ^ type_name - | TRef (r, rty, ref_kind) -> ( - match ref_kind with - | RMut -> - "&" ^ region_to_string env r ^ " mut (" ^ ty_to_string env rty ^ ")" - | RShared -> - "&" ^ region_to_string env r ^ " (" ^ ty_to_string env rty ^ ")") - | TRawPtr (rty, ref_kind) -> ( - match ref_kind with - | RMut -> "*mut " ^ ty_to_string env rty - | RShared -> "*const " ^ ty_to_string env rty) - | TFnPtr binder -> - let env = fmt_env_push_regions env binder.binder_regions in - let { inputs; output; _ } = binder.binder_value in - let inputs = - "(" ^ String.concat ", " (List.map (ty_to_string env) inputs) ^ ") -> " - in - inputs ^ ty_to_string env output - | TFnDef f -> - let env = fmt_env_push_regions env f.binder_regions in - let fn = fn_ptr_to_string env f.binder_value in - fn - | TDynTrait pred -> - let regions, clauses = - generic_params_to_strings env pred.binder.binder_params - in - let reg_str = - match regions with - | [] -> "" - | r :: _ -> " + " ^ r - in - "dyn (" ^ String.concat " + " clauses ^ reg_str ^ ")" - | TArray (ty, len) -> - "[" ^ ty_to_string env ty ^ "; " ^ constant_expr_to_string env len ^ "]" - | TSlice ty -> "[" ^ ty_to_string env ty ^ "]" - | TPtrMetadata ty -> "PtrMetadata(" ^ ty_to_string env ty ^ ")" - | TError msg -> "type_error (\"" ^ msg ^ "\")" - -(** Return two lists: - - one for the regions, types, const generics - - one for the trait refs *) -and generic_args_to_strings (env : 'a fmt_env) (generics : generic_args) : - string list * string list = - let { regions; types; const_generics; trait_refs } = generics in - let regions = List.map (region_to_string env) regions in - let types = List.map (ty_to_string env) types in - let cgs = List.map (constant_expr_to_string env) const_generics in - let params = List.flatten [ regions; types; cgs ] in - let trait_refs = List.map (trait_ref_to_string env) trait_refs in - (params, trait_refs) - -and generic_args_to_string (env : 'a fmt_env) (generics : generic_args) : string - = - let params, trait_refs = generic_args_to_strings env generics in - let params = - if params = [] then "" else "<" ^ String.concat ", " params ^ ">" - in - let trait_refs = - if trait_refs = [] then "" else "[" ^ String.concat ", " trait_refs ^ "]" - in - params ^ trait_refs - -and trait_ref_kind_to_string (env : 'a fmt_env) - (implements : trait_decl_ref region_binder option) (kind : trait_ref_kind) : - string = - match kind with - | Self -> "Self" - | TraitImpl impl_ref -> trait_impl_ref_to_string env impl_ref - | BuiltinOrAuto _ -> - region_binder_to_string trait_decl_ref_to_string env - (Option.get implements) - | Clause id -> trait_db_var_to_string env id - | ParentClause (tref, clause_id) -> - let inst_id = trait_ref_to_string env tref in - let clause_id = trait_clause_id_to_string env clause_id in - "parent(" ^ inst_id ^ ")::" ^ clause_id - | ItemClause (tref, name, clause_id) -> - let inst_id = trait_ref_to_string env tref in - let clause_id = trait_clause_id_to_string env clause_id in - "item(" ^ inst_id ^ ")::" ^ name ^ "::" ^ clause_id - | Dyn -> - let trait = - region_binder_to_string trait_decl_ref_to_string env - (Option.get implements) - in - "dyn(" ^ trait ^ ")" - | UnknownTrait msg -> "UNKNOWN(" ^ msg ^ ")" - -and trait_ref_to_string (env : 'a fmt_env) (tr : trait_ref) : string = - trait_ref_kind_to_string env (Some tr.trait_decl_ref) tr.kind - -and trait_decl_ref_to_string (env : 'a fmt_env) (tr : trait_decl_ref) : string = - let trait_id = trait_decl_id_to_string env tr.id in - let generics = generic_args_to_string env tr.generics in - trait_id ^ generics - -and impl_elem_to_string (env : 'a fmt_env) (elem : impl_elem) : string = - match elem with - | ImplElemTy bound_ty -> - (* Locally replace the generics and the predicates *) - let env = fmt_env_push_generics_and_preds env bound_ty.binder_params in - ty_to_string env bound_ty.binder_value - | ImplElemTrait impl_id -> begin - match TraitImplId.Map.find_opt impl_id env.crate.trait_impls with - | None -> trait_impl_id_to_string env impl_id - | Some impl -> ( - (* Locally replace the generics and the predicates *) - let env = fmt_env_push_generics_and_preds env impl.generics in - (* Put the first type argument aside (it gives the type for which we - implement the trait) *) - let { id; generics } : trait_decl_ref = impl.impl_trait in - match generics.types with - | ty :: types -> begin - let ty, types = Collections.List.pop generics.types in - let generics = { generics with types } in - let tr : trait_decl_ref = { id; generics } in - let ty = ty_to_string env ty in - let tr = trait_decl_ref_to_string env tr in - tr ^ " for " ^ ty - end - (* When monomorphizing, traits no longer take a `Self` argument, it's stored in the name *) - | [] -> trait_decl_ref_to_string env impl.impl_trait) - end - -and path_elem_to_string (env : 'a fmt_env) (e : path_elem) : string = - match e with - | PeIdent (s, d) -> - let d = - if d = Disambiguator.zero then "" else "#" ^ Disambiguator.to_string d - in - s ^ d - | PeImpl impl -> "{" ^ impl_elem_to_string env impl ^ "}" - | PeInstantiated binder -> - let env = fmt_env_push_generics_and_preds env binder.binder_params in - let explicits, _ = generic_args_to_strings env binder.binder_value in - "<" ^ String.concat ", " explicits ^ ">" - | PeTarget target -> target - -and name_to_string (env : 'a fmt_env) (n : name) : string = - let name = List.map (path_elem_to_string env) n in - String.concat "::" name - -and raw_attribute_to_string (attr : raw_attribute) : string = - let args = - match attr.args with - | None -> "" - | Some args -> "(" ^ args ^ ")" - in - attr.path ^ args - -and trait_param_to_string (env : 'a fmt_env) (clause : trait_param) : string = - let clause_id = trait_clause_id_to_string env clause.clause_id in - let trait = - region_binder_to_string trait_decl_ref_to_string env clause.trait - in - "[" ^ clause_id ^ "]: " ^ trait - -and generic_params_to_strings (env : 'a fmt_env) (generics : generic_params) : - string list * string list = - let ({ regions; types; const_generics; trait_clauses; _ } : generic_params) = - generics - in - let regions = List.map region_param_to_string regions in - let types = List.map type_param_to_string types in - let cgs = List.map const_generic_param_to_string const_generics in - let params = List.flatten [ regions; types; cgs ] in - let trait_clauses = List.map (trait_param_to_string env) trait_clauses in - (params, trait_clauses) - -and adt_variant_to_string (env : 'a fmt_env) (def_id : TypeDeclId.id) - (variant_id : VariantId.id) : string = - match TypeDeclId.Map.find_opt def_id env.crate.type_decls with - | None -> - type_decl_id_to_pretty_string def_id - ^ "::" - ^ variant_id_to_pretty_string variant_id - | Some def -> begin - match def.kind with - | Enum variants -> - let variant = VariantId.nth variants variant_id in - name_to_string env def.item_meta.name ^ "::" ^ variant.variant_name - | _ -> raise (Failure "Unreachable") - end - -and adt_field_names (env : 'a fmt_env) (def_id : TypeDeclId.id) - (opt_variant_id : VariantId.id option) : string list option = - match TypeDeclId.Map.find_opt def_id env.crate.type_decls with - | None -> None - | Some { kind = Opaque; _ } -> None - | Some def -> - let fields = type_decl_get_fields def opt_variant_id in - (* There are two cases: either all the fields have names, or none - of them has names *) - let has_names = - List.exists (fun f -> Option.is_some f.field_name) fields - in - if has_names then - let fields = List.map (fun f -> Option.get f.field_name) fields in - Some fields - else None - -let field_to_string env (f : field) : string = - match f.field_name with - | Some field_name -> field_name ^ " : " ^ ty_to_string env f.field_ty - | None -> ty_to_string env f.field_ty - -let variant_to_string env (v : variant) : string = - v.variant_name ^ "(" - ^ String.concat ", " (List.map (field_to_string env) v.fields) - ^ ")" - -let trait_type_constraint_to_string (env : 'a fmt_env) - (ttc : trait_type_constraint) : string = - let { trait_ref; type_name; ty } = ttc in - let trait_ref = trait_ref_to_string env trait_ref in - let ty = ty_to_string env ty in - trait_ref ^ "::" ^ type_name ^ " = " ^ ty - -(** Helper to format "where" clauses *) -let clauses_to_string (indent : string) (indent_incr : string) - (clauses : string list) : string = - if clauses = [] then "" - else - let env_clause s = indent ^ indent_incr ^ s ^ "," in - let clauses = List.map env_clause clauses in - "\n" ^ indent ^ "where\n" ^ String.concat "\n" clauses - -(** Helper to format "where" clauses *) -let predicates_and_trait_clauses_to_string (env : 'a fmt_env) (indent : string) - (indent_incr : string) (generics : generic_params) : string list * string = - let params, trait_clauses = generic_params_to_strings env generics in - let region_to_string = region_to_string env in - let regions_outlive = - let outlive_to_string _ (x, y) = - region_to_string x ^ " : " ^ region_to_string y - in - List.map - (region_binder_to_string outlive_to_string env) - generics.regions_outlive - in - let types_outlive = - let outlive_to_string _ (x, y) = - ty_to_string env x ^ " : " ^ region_to_string y - in - List.map - (region_binder_to_string outlive_to_string env) - generics.types_outlive - in - let trait_type_constraints = - List.map - (region_binder_to_string trait_type_constraint_to_string env) - generics.trait_type_constraints - in - (* Split between the inherited clauses and the local clauses *) - let clauses = - clauses_to_string indent indent_incr - (List.concat - [ - trait_clauses; regions_outlive; types_outlive; trait_type_constraints; - ]) - in - (params, clauses) - -let type_decl_to_string (env : 'a fmt_env) (def : type_decl) : string = - (* Locally update the generics and the predicates *) - let env = fmt_env_push_generics_and_preds env def.generics in - let params, clauses = - predicates_and_trait_clauses_to_string env "" " " def.generics - in - - let name = name_to_string env def.item_meta.name in - let params = - if params <> [] then "<" ^ String.concat ", " params ^ ">" else "" - in - match def.kind with - | Struct fields -> - if fields <> [] then - let fields = - String.concat "" - (List.map (fun f -> "\n " ^ field_to_string env f ^ ",") fields) - in - "struct " ^ name ^ params ^ clauses ^ "\n{" ^ fields ^ "\n}" - else "struct " ^ name ^ params ^ clauses ^ "{}" - | Enum variants -> - let variants = - List.map (fun v -> "| " ^ variant_to_string env v) variants - in - let variants = String.concat "\n" variants in - "enum " ^ name ^ params ^ clauses ^ "\n =\n" ^ variants - | Union fields -> - if fields <> [] then - let fields = - String.concat "" - (List.map (fun f -> "\n " ^ field_to_string env f ^ ",") fields) - in - "union " ^ name ^ params ^ clauses ^ "\n{" ^ fields ^ "\n}" - else "union " ^ name ^ params ^ clauses ^ "{}" - | Alias ty -> "type " ^ name ^ params ^ clauses ^ " = " ^ ty_to_string env ty - | Opaque -> "opaque type " ^ name ^ params ^ clauses - | TDeclError err -> "error(\"" ^ err ^ "\")" - -let adt_field_to_string (env : 'a fmt_env) (def_id : TypeDeclId.id) - (opt_variant_id : VariantId.id option) (field_id : FieldId.id) : - string option = - match TypeDeclId.Map.find_opt def_id env.crate.type_decls with - | None -> None - | Some { kind = Opaque; _ } -> None - | Some def -> - let fields = type_decl_get_fields def opt_variant_id in - let field = FieldId.nth fields field_id in - field.field_name diff --git a/charon-ml/src/PrintUllbcAst.ml b/charon-ml/src/PrintUllbcAst.ml deleted file mode 100644 index 7748f1e1a..000000000 --- a/charon-ml/src/PrintUllbcAst.ml +++ /dev/null @@ -1,182 +0,0 @@ -open PrintUtils -open Types -open TypesUtils -open UllbcAst -open PrintTypes -open PrintValues -open PrintExpressions - -type fmt_env = blocks PrintUtils.fmt_env - -(** Pretty-printing for ULLBC AST (generic functions) *) -module Ast = struct - include PrintGAst - - let rec statement_to_string (env : fmt_env) (indent : string) (st : statement) - : string = - statement_kind_to_string env indent st.kind - - and statement_kind_to_string (env : fmt_env) (indent : string) - (st : statement_kind) : string = - match st with - | Assign (p, rv) -> - indent ^ place_to_string env p ^ " := " ^ rvalue_to_string env rv - | SetDiscriminant (p, variant_id) -> - (* TODO: improve this to lookup the variant name by using the def id - (we are missing the def id here) *) - indent ^ "set_discriminant(" ^ place_to_string env p ^ ", " - ^ variant_id_to_pretty_string variant_id - ^ ")" - | Assert (asrt, abort_kind) -> - indent - ^ assertion_to_string env asrt - ^ " else " - ^ abort_kind_to_string env abort_kind - | StorageLive var_id -> - indent ^ "storage_live " ^ local_id_to_string env var_id - | StorageDead var_id -> - indent ^ "storage_dead " ^ local_id_to_string env var_id - | PlaceMention place -> indent ^ "_ := " ^ place_to_string env place - | CopyNonOverlapping { src; dst; count } -> - indent ^ "copy_non_overlapping(" ^ operand_to_string env src ^ ", " - ^ operand_to_string env dst ^ ", " - ^ operand_to_string env count - ^ ")" - | Nop -> "nop" - - let switch_to_string (indent : string) (tgt : switch) : string = - match tgt with - | If (b0, b1) -> - let b0 = block_id_to_string b0 in - let b1 = block_id_to_string b1 in - indent ^ "[true -> " ^ b0 ^ "; false -> " ^ b1 ^ "]" - | SwitchInt (_int_ty, branches, otherwise) -> - let branches = - List.map - (fun (sv, bid) -> - literal_to_string sv ^ " -> " ^ block_id_to_string bid ^ "; ") - branches - in - let branches = String.concat "" branches in - let otherwise = "_ -> " ^ block_id_to_string otherwise in - indent ^ "[" ^ branches ^ otherwise ^ "]" - - let rec terminator_to_string (env : fmt_env) (indent : string) - (st : terminator) : string = - terminator_kind_to_string env indent st.kind - - and terminator_kind_to_string (env : fmt_env) (indent : string) - (st : terminator_kind) : string = - match st with - | Goto bid -> indent ^ "goto " ^ block_id_to_string bid - | Switch (op, tgts) -> - indent ^ "switch " ^ operand_to_string env op - ^ switch_to_string indent tgts - | Call (call, tgt, unwind) -> - call_to_string env indent call - ^ " -> " ^ block_id_to_string tgt ^ "(unwind:" - ^ block_id_to_string unwind ^ ")" - | Drop (_, p, _, tgt, unwind) -> - indent ^ "drop " ^ place_to_string env p ^ " -> " - ^ block_id_to_string tgt ^ "(unwind:" ^ block_id_to_string unwind ^ ")" - | TAssert (asrt, tgt, unwind) -> - indent - ^ assertion_to_string env asrt - ^ " -> " ^ block_id_to_string tgt ^ "(unwind:" - ^ block_id_to_string unwind ^ ")" - | Abort _ -> indent ^ "panic" - | Return -> indent ^ "return" - | UnwindResume -> indent ^ "unwind_continue" - - let block_to_string (env : fmt_env) (indent : string) (indent_incr : string) - (id : BlockId.id) (block : block) : string = - let indent1 = indent ^ indent_incr in - let statements = - List.map - (fun st -> statement_to_string env indent1 st ^ ";\n") - block.statements - in - let terminator = terminator_to_string env indent1 block.terminator in - indent ^ block_id_to_string id ^ " {\n" - ^ String.concat "" statements - ^ terminator ^ ";\n" ^ indent ^ "}" - - let blocks_to_string (env : fmt_env) (indent : string) (indent_incr : string) - (blocks : block list) : string = - let blocks = BlockId.mapi (block_to_string env indent indent_incr) blocks in - String.concat "\n\n" blocks - - let fun_decl_to_string (env : fmt_env) (indent : string) - (indent_incr : string) (def : fun_decl) : string = - gfun_decl_to_string env indent indent_incr blocks_to_string def - - let global_decl_to_string (env : fmt_env) (indent : string) - (indent_incr : string) (def : global_decl) : string = - (* Locally update the generics and the predicates *) - let env = fmt_env_replace_generics_and_preds env def.generics in - let params, clauses = - predicates_and_trait_clauses_to_string env "" " " def.generics - in - let params = - if params <> [] then "<" ^ String.concat ", " params ^ ">" else "" - in - - let name = name_to_string env def.item_meta.name in - let ty = ty_to_string env def.ty in - - let body_id = fun_decl_id_to_string env def.init in - indent ^ "global " ^ name ^ params ^ clauses ^ " : " ^ ty ^ " = " ^ body_id -end - -(** Pretty-printing for ASTs (functions based on a declaration context) *) -module Crate = struct - open Ast - - let crate_to_fmt_env (crate : crate) : fmt_env = - { crate; generics = []; locals = [] } - - let crate_to_string (m : crate) : string = - let env : fmt_env = crate_to_fmt_env m in - - (* The types *) - let type_decls = - List.map - (fun (_, d) -> type_decl_to_string env d) - (TypeDeclId.Map.bindings m.type_decls) - in - - (* The globals *) - let global_decls = - List.map - (fun (_, d) -> global_decl_to_string env "" " " d) - (GlobalDeclId.Map.bindings m.global_decls) - in - - (* The functions *) - let fun_decls = - List.map - (fun (_, d) -> fun_decl_to_string env "" " " d) - (FunDeclId.Map.bindings m.fun_decls) - in - - (* The trait declarations *) - let trait_decls = - List.map - (fun (_, d) -> trait_decl_to_string env "" " " d) - (TraitDeclId.Map.bindings m.trait_decls) - in - - (* The trait implementations *) - let trait_impls = - List.map - (fun (_, d) -> trait_impl_to_string env "" " " d) - (TraitImplId.Map.bindings m.trait_impls) - in - - (* Put everything together *) - let all_defs = - List.concat - [ type_decls; global_decls; trait_decls; trait_impls; fun_decls ] - in - String.concat "\n\n" all_defs -end diff --git a/charon-ml/src/PrintUtils.ml b/charon-ml/src/PrintUtils.ml index ebf095249..e70516f2a 100644 --- a/charon-ml/src/PrintUtils.ml +++ b/charon-ml/src/PrintUtils.ml @@ -13,8 +13,8 @@ let block_id_to_string (id : UllbcAst.BlockId.id) : string = (** The formatting environment can be incomplete: if some information is missing (for instance we can't find the type variable for a given index) we print the id in raw format. *) -type 'fun_body fmt_env = { - crate : 'fun_body gcrate; +type fmt_env = { + crate : crate; generics : generic_params list; (** We have a stack of generic parameters, because we can dive into binders (for instance because of the arrow type). *) @@ -22,19 +22,18 @@ type 'fun_body fmt_env = { (** The local variables don't need to be ordered (same as the generics) *) } -let of_crate (crate : 'fun_body gcrate) : 'fun_body fmt_env = - { crate; generics = []; locals = [] } +let of_crate (crate : crate) : fmt_env = { crate; generics = []; locals = [] } -let fmt_env_push_generics_and_preds (env : 'a fmt_env) - (generics : generic_params) : 'a fmt_env = +let fmt_env_push_generics_and_preds (env : fmt_env) (generics : generic_params) + : fmt_env = { env with generics = generics :: env.generics } -let fmt_env_replace_generics_and_preds (env : 'a fmt_env) - (generics : generic_params) : 'a fmt_env = +let fmt_env_replace_generics_and_preds (env : fmt_env) + (generics : generic_params) : fmt_env = { env with generics = [ generics ] } -let fmt_env_push_regions (env : 'a fmt_env) (regions : region_param list) : - 'a fmt_env = +let fmt_env_push_regions (env : fmt_env) (regions : region_param list) : fmt_env + = { env with generics = { TypesUtils.empty_generic_params with regions } :: env.generics; diff --git a/charon-ml/src/PrintValues.ml b/charon-ml/src/PrintValues.ml deleted file mode 100644 index e979ab65c..000000000 --- a/charon-ml/src/PrintValues.ml +++ /dev/null @@ -1,50 +0,0 @@ -(** Pretty-printing for primitive values *) - -open Values -open Types - -let integer_type_to_string = function - | Signed Isize -> "isize" - | Signed I8 -> "i8" - | Signed I16 -> "i16" - | Signed I32 -> "i32" - | Signed I64 -> "i64" - | Signed I128 -> "i128" - | Unsigned Usize -> "usize" - | Unsigned U8 -> "u8" - | Unsigned U16 -> "u16" - | Unsigned U32 -> "u32" - | Unsigned U64 -> "u64" - | Unsigned U128 -> "u128" - -let float_type_to_string = function - | F16 -> "f16" - | F32 -> "f32" - | F64 -> "f64" - | F128 -> "f128" - -let literal_type_to_string (ty : literal_type) : string = - match ty with - | TInt ity -> integer_type_to_string (Signed ity) - | TUInt uty -> integer_type_to_string (Unsigned uty) - | TFloat fty -> float_type_to_string fty - | TBool -> "bool" - | TChar -> "char" - -let big_int_to_string (bi : big_int) : string = Z.to_string bi - -let scalar_value_to_string (sv : scalar_value) : string = - big_int_to_string (Scalars.get_val sv) - ^ integer_type_to_string (Scalars.get_ty sv) - -let float_value_to_string (fv : float_value) : string = - fv.float_value ^ float_type_to_string fv.float_ty - -let literal_to_string (lit : literal) : string = - match lit with - | VScalar sv -> scalar_value_to_string sv - | VFloat fv -> float_value_to_string fv - | VBool b -> Bool.to_string b - | VChar c -> Uchar.to_string c - | VStr s -> "\"" ^ s ^ "\"" - | VByteStr bs -> "[" ^ String.concat ", " (List.map string_of_int bs) ^ "]" diff --git a/charon-ml/src/Substitute.ml b/charon-ml/src/Substitute.ml index a28cebcfb..6f2497153 100644 --- a/charon-ml/src/Substitute.ml +++ b/charon-ml/src/Substitute.ml @@ -601,7 +601,7 @@ let lookup_and_subst_trait_impl_method (timpl : trait_impl) generics. Returns [None] if the trait or method declarations could not be found. *) -let lookup_method_sig (crate : 'a gcrate) (trait_id : trait_decl_id) +let lookup_method_sig (crate : crate) (trait_id : trait_decl_id) (name : trait_item_name) : fun_sig binder item_binder option = let* tdecl = TraitDeclId.Map.find_opt trait_id crate.trait_decls in let* { @@ -629,14 +629,14 @@ let lookup_method_sig (crate : 'a gcrate) (trait_id : trait_decl_id) (* Like [lookup_method_sig], but with no binder shenanigans: the returned binder binds the concatenation of trait generics and method generics. *) -let lookup_flat_method_sig (crate : 'a gcrate) (trait_id : trait_decl_id) +let lookup_flat_method_sig (crate : crate) (trait_id : trait_decl_id) (name : trait_item_name) : bound_fun_sig option = let* bound_sig = lookup_method_sig crate trait_id name in let bound_sig = fuse_binders st_substitute_visitor#visit_fun_sig bound_sig in Some bound_sig (* Lookup the signature of a `Ty::FnDef`. *) -let lookup_fndef_sig (crate : 'a gcrate) (fn_ptr : fn_ptr region_binder) : +let lookup_fndef_sig (crate : crate) (fn_ptr : fn_ptr region_binder) : fun_sig region_binder option = match fn_ptr.binder_value.kind with | FunId (FRegular fun_decl_id) -> diff --git a/charon-ml/src/UllbcAst.ml b/charon-ml/src/UllbcAst.ml index 5dbae0839..c80a37bfe 100644 --- a/charon-ml/src/UllbcAst.ml +++ b/charon-ml/src/UllbcAst.ml @@ -7,8 +7,4 @@ include GAst include Generated_UllbcAst type expr_body = blocks gexpr_body [@@deriving show] -type fun_body = blocks body [@@deriving show] -type fun_decl = blocks gfun_decl [@@deriving show] - -(** ULLBC crate *) -type crate = blocks gcrate [@@deriving show] +type fun_body = expr_body [@@deriving show] diff --git a/charon-ml/src/UllbcOfJson.ml b/charon-ml/src/UllbcOfJson.ml deleted file mode 100644 index 22b1d6f1b..000000000 --- a/charon-ml/src/UllbcOfJson.ml +++ /dev/null @@ -1,44 +0,0 @@ -(** Functions to load ULLBC ASTs from json. - - See the comments for {!GAstOfJson} *) - -open OfJsonBasic -open Types -open Expressions -open UllbcAst -include GAstOfJson -include Generated_UllbcOfJson - -let expr_body_of_json (ctx : of_json_ctx) (js : json) : - (fun_body, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Unstructured", body) ] -> - let* body = gexpr_body_of_json (list_of_json block_of_json) ctx body in - Ok (Body body) - | `String "TraitMethodWithoutDefault" -> Ok TraitMethodWithoutDefault - | `Assoc [ ("Extern", sym) ] -> - let* sym = string_of_json ctx sym in - Ok (Extern sym) - | `Assoc - [ ("Intrinsic", `Assoc [ ("name", name); ("arg_names", arg_names) ]) ] - -> - let* name = string_of_json ctx name in - let* arg_names = list_of_json string_of_json ctx arg_names in - Ok (Intrinsic { name; arg_names }) - | `Assoc [ ("TargetDispatch", targets) ] -> - let* targets = - list_of_json - (key_value_pair_of_json string_of_json fun_decl_ref_of_json) - ctx targets - in - Ok (TargetDispatch targets) - | `String "Opaque" -> Ok Opaque - | `String "Missing" -> Ok Missing - | `Assoc [ ("Error", e) ] -> - let* e = error_of_json ctx e in - Ok (GAst.Error e) - | _ -> Error "") - -let crate_of_json (js : json) : (crate, string) result = - gcrate_of_json expr_body_of_json js diff --git a/charon-ml/src/generated/Generated_Expressions.ml b/charon-ml/src/generated/Generated_Expressions.ml index a52a6eabc..772a02b28 100644 --- a/charon-ml/src/generated/Generated_Expressions.ml +++ b/charon-ml/src/generated/Generated_Expressions.ml @@ -8,8 +8,8 @@ code-generation code is in `charon/src/bin/generate-ml`. *) open Identifiers -open Types -open Values +open Generated_Types +open Generated_Values module LocalId = IdGen () module GlobalDeclId = Types.GlobalDeclId module FunDeclId = Types.FunDeclId diff --git a/charon-ml/src/generated/Generated_FullAst.ml b/charon-ml/src/generated/Generated_FullAst.ml new file mode 100644 index 000000000..6c666666f --- /dev/null +++ b/charon-ml/src/generated/Generated_FullAst.ml @@ -0,0 +1,319 @@ +(** WARNING: this file is partially auto-generated. Do not edit `FullAst.ml` by + hand. Edit `templates/FullAst.ml` instead, or improve the code generation + tool so avoid the need for hand-writing things. + + `templates/FullAst.ml` contains the manual definitions and some `(* + __REPLACEn__ *)` comments. These comments are replaced by auto-generated + definitions by running `make generate-ml` in the crate root. The + code-generation code is in `charon/src/bin/generate-ml`. *) + +open Generated_GAst +open Generated_UllbcAst +open Generated_LlbcAst +open Generated_Types +open Generated_Values +open Generated_Expressions +open Generated_Meta +open Identifiers + +(** The body of a function. *) +type body = + | UnstructuredBody of Generated_UllbcAst.block list gexpr_body + (** Body represented as a CFG. This is what ullbc is made of, and what we + get after translating MIR. *) + | StructuredBody of Generated_LlbcAst.block gexpr_body + (** Body represented with structured control flow. This is what llbc is + made of. We restructure the control flow in the [ullbc_to_llbc] pass. + *) + | TargetDispatchBody of (string * fun_decl_ref) list + (** A façade body that dispatches to one of several per-target function + bodies. Created during multi-target merging for functions with the + same signature but different bodies across targets. *) + | TraitMethodWithoutDefaultBody + (** The body of the function item we add for each trait method + declaration, if the trait doesn't provide a default for that method. + *) + | ExternBody of string + (** Function declared in an [extern { ... }] block. The string is the + foreign symbol name. *) + | IntrinsicBody of string * string option list + (** Rust intrinsic function. + + Fields: + - [name]: The intrinsic name. + - [arg_names]: The argument names, None if not available. *) + | OpaqueBody + (** A body that the user chose not to translate, based on opacity settings + like [--include]/[--opaque]. *) + | MissingBody + (** A body that was not available. Typically that's function bodies for + non-generic and non-inlineable std functions, as these are not present + in the compiled standard library [.rmeta] file shipped with a rust + toolchain. *) + | ErrorBody of error + (** We encountered an error while translating this body. *) + +and cli_options = { + ullbc : bool; + (** Extract the unstructured LLBC (i.e., don't reconstruct the + control-flow) *) + precise_drops : bool; + (** Whether to precisely translate drops and drop-related code. For this, + we add explicit [Destruct] bounds to all generic parameters, set the + MIR level to at least [elaborated], and attempt to retrieve drop glue + for all types. + + This option is known to cause panics inside rustc, because their drop + handling is not design to work on polymorphic types. To silence the + warning, pass appropriate + [--opaque '{impl core::marker::Destruct for some::Type}'] options. + + Without this option, drops may be "conditional" and we may lack + information about what code is run on drop in a given polymorphic + function body. *) + skip_borrowck : bool; + (** If activated, this skips borrow-checking of the crate. *) + mir : mir_level option; + (** The MIR stage to extract. This is only relevant for the current crate; + for dpendencies only MIR optimized is available. *) + rustc_args : string list; (** Extra flags to pass to rustc. *) + targets : string list; + (** A list of target architectures to translate for. Charon will run the + compiler once for each target and aggregate the results, which is + useful if the code includes [#[cfg(..)]] filters. Warning: this is an + initial implementation which is extremely slow. *) + monomorphize : bool; + (** Monomorphize the items encountered when possible. Generic items found + in the crate are skipped. To only translate a particular call graph, + use [--start-from]. Note: this doesn't currently support [dyn Trait]. + *) + monomorphize_mut : monomorphize_mut option; + (** Partially monomorphize items to make it so that no item is ever + monomorphized with a mutable reference (or type containing one); said + differently, so that the presence of mutable references in a type is + independent of its generics. This is used by Aeneas. *) + start_from : string list; + (** A list of item paths to use as starting points for the translation. We + will translate these items and any items they refer to, according to + the opacity rules. When absent, we start from the path [crate] (which + translates the whole crate). *) + start_from_if_exists : string list; + (** Same as --start-from, but won't raise an error if a pattern doesn't + match any item. This is useful when the patterns are generated by a + build script and may be out of sync with the code. *) + start_from_attribute : string option; + (** Use all the items annotated with the given attribute as starting + points for translation (except modules). If an attribute name is not + specified, [verify::start_from] is used. *) + start_from_pub : bool; + (** Use all the [pub] items as starting points for translation (except + modules). *) + included : string list; + (** Whitelist of items to translate. These use the name-matcher syntax. *) + opaque : string list; + (** Blacklist of items to keep opaque. Works just like [--include], see + the doc there. *) + exclude : string list; + (** Blacklist of items to not translate at all. Works just like + [--include], see the doc there. *) + extract_opaque_bodies : bool; + (** Usually we skip the bodies of foreign methods and structs with private + fields. When this flag is on, we don't. *) + translate_all_methods : bool; + (** Usually we skip the provided methods that aren't used. When this flag + is on, we translate them all. *) + lift_associated_types : string list; + (** Transform the associate types of traits to be type parameters instead. + This takes a list of name patterns of the traits to transform, using + the same syntax as [--include]. *) + hide_marker_traits : bool; + (** Whether to hide various marker traits such as [Sized], [Sync], [Send] + and [Destruct] anywhere they show up. This can considerably speed up + translation. *) + remove_adt_clauses : bool; + (** Remove trait clauses from type declarations. Must be combined with + [--remove-associated-types] for type declarations that use trait + associated types in their fields, otherwise this will result in + errors. *) + hide_allocator : bool; + (** Hide the [A] type parameter on standard library containers ([Box], + [Vec], etc). *) + remove_unused_self_clauses : bool; + (** Trait method declarations take a [Self: Trait] clause as parameter, so + that they can be reused by multiple trait impls. This however causes + trait definitions to be mutually recursive with their method + declarations. This flag removes [Self] clauses that aren't used to + break this mutual recursion when possible. *) + desugar_drops : bool; + (** Transform precise drops to the equivalent [drop_in_place(&raw mut p)] + call. *) + ops_to_function_calls : bool; + (** Transform array-to-slice unsizing, repeat expressions, and raw pointer + construction into builtin functions in ULLBC. *) + index_to_function_calls : bool; + (** Transform array/slice indexing into builtin functions in ULLBC. Note + that this may introduce UB since it creates references that were not + normally created, including when indexing behind a raw pointer. *) + treat_box_as_builtin : bool; + (** Treat [Box] as if it was a built-in type. *) + raw_consts : bool; (** Do not inline or evaluate constants. *) + unsized_strings : bool; + (** Replace string literal constants with a constant u8 array that gets + unsized, expliciting the fact a string constant has a hidden + reference. *) + reconstruct_fallible_operations : bool; + (** Replace "bound checks followed by UB-on-overflow operation" with the + corresponding panic-on-overflow operation. This loses unwinding + information. *) + reconstruct_asserts : bool; + (** Replace [if x { panic() }] with [assert(x)]. *) + unbind_item_vars : bool; + (** Use [DeBruijnVar::Free] for the variables bound in item signatures, + instead of [DeBruijnVar::Bound] everywhere. This simplifies the + management of generics for projects that don't intend to manipulate + them too much. *) + print_original_ullbc : bool; + (** Pretty-print the ULLBC immediately after extraction from MIR. *) + print_ullbc : bool; + (** Pretty-print the ULLBC after applying the micro-passes (before + serialization/control-flow reconstruction). *) + print_built_llbc : bool; + (** Pretty-print the LLBC just after we built it (i.e., immediately after + loop reconstruction). *) + print_llbc : bool; + (** Pretty-print the final LLBC (after all the cleaning micro-passes). *) + dest_dir : path_buf option; + (** The destination directory. Files will be generated as + [/.{u}llbc], unless [dest_file] is set. + [dest_dir] defaults to the current directory. *) + dest_file : path_buf option; + (** The destination file. By default [/.llbc]. If + this is set we ignore [dest_dir]. *) + no_dedup_serialized_ast : bool; + (** Don't deduplicate values (types, trait refs) in the .(u)llbc file. + This makes the file easier to inspect. *) + no_serialize : bool; (** Don't serialize the final (U)LLBC to a file. *) + no_typecheck : bool; (** Skip the typecheck passes. *) + no_normalize : bool; (** Don't normalize associated types. *) + abort_on_error : bool; + (** Panic on the first error. This is useful for debugging. *) + error_on_warnings : bool; (** Consider any warnings to be errors. *) + preset : preset option; (** Named builtin sets of options. *) +} + +(** A (group of) top-level declaration(s), properly reordered. *) +and declaration_group = + | TypeGroup of type_decl_id g_declaration_group + (** A type declaration group *) + | FunGroup of fun_decl_id g_declaration_group + (** A function declaration group *) + | GlobalGroup of global_decl_id g_declaration_group + (** A global declaration group *) + | TraitDeclGroup of trait_decl_id g_declaration_group + | TraitImplGroup of trait_impl_id g_declaration_group + | MixedGroup of item_id g_declaration_group + (** Anything that doesn't fit into these categories. *) + +(** A function definition *) +and fun_decl = { + def_id : fun_decl_id; + item_meta : item_meta; (** The meta data associated with the declaration. *) + generics : generic_params; + signature : fun_sig; + (** The signature contains the inputs/output types *with* non-erased + regions. It also contains the list of region and type parameters. *) + src : item_source; + (** The function kind: "regular" function, trait method declaration, etc. + *) + is_global_initializer : global_decl_id option; + (** Whether this function is in fact the body of a constant/static that we + turned into an initializer function. *) + body : body; (** The function body. *) +} + +(** A (group of) top-level declaration(s), properly reordered. "G" stands for + "generic" *) +and 'a0 g_declaration_group = + | NonRecGroup of 'a0 (** A non-recursive declaration *) + | RecGroup of 'a0 list (** A (group of mutually) recursive declaration(s) *) + +(** The MIR stage to use. This is only relevant for the current crate: for + dependencies, only mir optimized is available (or mir elaborated for + consts). *) +and mir_level = + | Built (** The MIR just after MIR lowering. *) + | Promoted + (** The MIR after const promotion. This is the MIR used by the + borrow-checker. *) + | Elaborated + (** The MIR after drop elaboration. This is the first MIR to include all + the runtime information. *) + | Optimized + (** The MIR after optimizations. Charon disables all the optimizations it + can, so this is sensibly the same MIR as the elaborated MIR. *) + +and monomorphize_mut = + | All (** Monomorphize any item instantiated with [&mut]. *) + | ExceptTypes + (** Monomorphize all non-typedecl items instantiated with [&mut]. *) + +(** Presets to make it easier to tweak options without breaking dependent + projects. Eventually we should define semantically-meaningful presets + instead of project-specific ones. *) +and preset = + | OldDefaults + (** The default translation used before May 2025. After that, many passes + were made optional and disabled by default. *) + | RawMir + (** Emit the MIR as unmodified as possible. This is very imperfect for + now, we should make more passes optional. *) + | Fast (** Skip as many optional transformations as possible. *) + | Aeneas + | Eurydice + | Soteria + | Tests + +and target_info = { + target_pointer_size : int; (** The pointer size of the target in bytes. *) + is_little_endian : bool; + (** Whether the target platform uses little endian byte order. *) +} + +(** The data of a translated crate. *) +and translated_crate = { + crate_name : string; (** The name of the crate. *) + options : cli_options; + (** The options used when calling Charon. It is useful for the + applications which consumed the serialized code, to check that Charon + was called with the proper options. *) + target_information : (string * target_info) list; + (** Information about each target platform. When translating a crate + normally this will have a single entry; when using [--targets] this + will have one entry per chosen target. *) + files : file list; + (** The translated files. This field must come before any field containing + spans, as the OCaml deserialization of spans requires the files to be + deserialized already. *) + item_names : (item_id * name) list; + (** The names of all registered items. Available so we can know the names + even of items that failed to translate. Invariant: after translation, + any existing [ItemId] must have an associated name, even if the + corresponding item wasn't translated. *) + short_names : (item_id * name) list; + (** Short names, for items whose last PathElem is unique. *) + type_decls : type_decl option list; (** The translated type definitions *) + fun_decls : fun_decl option list; (** The translated function definitions *) + global_decls : global_decl option list; + (** The translated global definitions *) + trait_decls : trait_decl option list; + (** The translated trait declarations *) + trait_impls : trait_impl option list; + (** The translated trait declarations *) + unit_metadata : global_decl_ref option; + (** A [const UNIT: () = ();] used whenever we make a thin + pointer/reference to avoid creating a local [let unit = ();] variable. + It is always [Some]. *) + ordered_decls : declaration_group list option; + (** The re-ordered groups of declarations, initialized as empty. *) +} +[@@deriving show] diff --git a/charon-ml/src/generated/Generated_GAst.ml b/charon-ml/src/generated/Generated_GAst.ml index d5ffb6b22..44a093ef2 100644 --- a/charon-ml/src/generated/Generated_GAst.ml +++ b/charon-ml/src/generated/Generated_GAst.ml @@ -7,9 +7,9 @@ running `make generate-ml` in the crate root. The code-generation code is in `charon/src/bin/generate-ml`. *) -open Types -open Meta -open Expressions +open Generated_Types +open Generated_Meta +open Generated_Expressions module FunDeclId = Expressions.FunDeclId module GlobalDeclId = Expressions.GlobalDeclId module TraitDeclId = Types.TraitDeclId @@ -328,6 +328,18 @@ and trait_method = { nude = true (* Don't inherit VisitorsRuntime *); }] +(** An expression body. TODO: arg_count should be stored in GFunDecl below. But + then, the print is obfuscated and Aeneas may need some refactoring. *) +type 'a0 gexpr_body = { + span : span; + bound_body_regions : int; + (** The number of regions existentially bound in this body. We introduce + fresh such regions during translation instead of the erased regions + that rustc gives us. *) + locals : locals; (** The local variables. *) + body : 'a0; (** The statements and blocks that compose this body. *) +} + (** A trait **implementation**. For instance: @@ -338,7 +350,7 @@ and trait_method = { fn baz(...) { ... } } ]} *) -type trait_impl = { +and trait_impl = { def_id : trait_impl_id; item_meta : item_meta; impl_trait : trait_decl_ref; @@ -377,219 +389,3 @@ type trait_impl = { ancestors = [ "map_trait_decl" ]; nude = true (* Don't inherit VisitorsRuntime *); }] - -type cli_options = { - ullbc : bool; - (** Extract the unstructured LLBC (i.e., don't reconstruct the - control-flow) *) - precise_drops : bool; - (** Whether to precisely translate drops and drop-related code. For this, - we add explicit [Destruct] bounds to all generic parameters, set the - MIR level to at least [elaborated], and attempt to retrieve drop glue - for all types. - - This option is known to cause panics inside rustc, because their drop - handling is not design to work on polymorphic types. To silence the - warning, pass appropriate - [--opaque '{impl core::marker::Destruct for some::Type}'] options. - - Without this option, drops may be "conditional" and we may lack - information about what code is run on drop in a given polymorphic - function body. *) - skip_borrowck : bool; - (** If activated, this skips borrow-checking of the crate. *) - mir : mir_level option; - (** The MIR stage to extract. This is only relevant for the current crate; - for dpendencies only MIR optimized is available. *) - rustc_args : string list; (** Extra flags to pass to rustc. *) - targets : string list; - (** A list of target architectures to translate for. Charon will run the - compiler once for each target and aggregate the results, which is - useful if the code includes [#[cfg(..)]] filters. Warning: this is an - initial implementation which is extremely slow. *) - monomorphize : bool; - (** Monomorphize the items encountered when possible. Generic items found - in the crate are skipped. To only translate a particular call graph, - use [--start-from]. Note: this doesn't currently support [dyn Trait]. - *) - monomorphize_mut : monomorphize_mut option; - (** Partially monomorphize items to make it so that no item is ever - monomorphized with a mutable reference (or type containing one); said - differently, so that the presence of mutable references in a type is - independent of its generics. This is used by Aeneas. *) - start_from : string list; - (** A list of item paths to use as starting points for the translation. We - will translate these items and any items they refer to, according to - the opacity rules. When absent, we start from the path [crate] (which - translates the whole crate). *) - start_from_if_exists : string list; - (** Same as --start-from, but won't raise an error if a pattern doesn't - match any item. This is useful when the patterns are generated by a - build script and may be out of sync with the code. *) - start_from_attribute : string option; - (** Use all the items annotated with the given attribute as starting - points for translation (except modules). If an attribute name is not - specified, [verify::start_from] is used. *) - start_from_pub : bool; - (** Use all the [pub] items as starting points for translation (except - modules). *) - included : string list; - (** Whitelist of items to translate. These use the name-matcher syntax. *) - opaque : string list; - (** Blacklist of items to keep opaque. Works just like [--include], see - the doc there. *) - exclude : string list; - (** Blacklist of items to not translate at all. Works just like - [--include], see the doc there. *) - extract_opaque_bodies : bool; - (** Usually we skip the bodies of foreign methods and structs with private - fields. When this flag is on, we don't. *) - translate_all_methods : bool; - (** Usually we skip the provided methods that aren't used. When this flag - is on, we translate them all. *) - lift_associated_types : string list; - (** Transform the associate types of traits to be type parameters instead. - This takes a list of name patterns of the traits to transform, using - the same syntax as [--include]. *) - hide_marker_traits : bool; - (** Whether to hide various marker traits such as [Sized], [Sync], [Send] - and [Destruct] anywhere they show up. This can considerably speed up - translation. *) - remove_adt_clauses : bool; - (** Remove trait clauses from type declarations. Must be combined with - [--remove-associated-types] for type declarations that use trait - associated types in their fields, otherwise this will result in - errors. *) - hide_allocator : bool; - (** Hide the [A] type parameter on standard library containers ([Box], - [Vec], etc). *) - remove_unused_self_clauses : bool; - (** Trait method declarations take a [Self: Trait] clause as parameter, so - that they can be reused by multiple trait impls. This however causes - trait definitions to be mutually recursive with their method - declarations. This flag removes [Self] clauses that aren't used to - break this mutual recursion when possible. *) - desugar_drops : bool; - (** Transform precise drops to the equivalent [drop_in_place(&raw mut p)] - call. *) - ops_to_function_calls : bool; - (** Transform array-to-slice unsizing, repeat expressions, and raw pointer - construction into builtin functions in ULLBC. *) - index_to_function_calls : bool; - (** Transform array/slice indexing into builtin functions in ULLBC. Note - that this may introduce UB since it creates references that were not - normally created, including when indexing behind a raw pointer. *) - treat_box_as_builtin : bool; - (** Treat [Box] as if it was a built-in type. *) - raw_consts : bool; (** Do not inline or evaluate constants. *) - unsized_strings : bool; - (** Replace string literal constants with a constant u8 array that gets - unsized, expliciting the fact a string constant has a hidden - reference. *) - reconstruct_fallible_operations : bool; - (** Replace "bound checks followed by UB-on-overflow operation" with the - corresponding panic-on-overflow operation. This loses unwinding - information. *) - reconstruct_asserts : bool; - (** Replace [if x { panic() }] with [assert(x)]. *) - unbind_item_vars : bool; - (** Use [DeBruijnVar::Free] for the variables bound in item signatures, - instead of [DeBruijnVar::Bound] everywhere. This simplifies the - management of generics for projects that don't intend to manipulate - them too much. *) - print_original_ullbc : bool; - (** Pretty-print the ULLBC immediately after extraction from MIR. *) - print_ullbc : bool; - (** Pretty-print the ULLBC after applying the micro-passes (before - serialization/control-flow reconstruction). *) - print_built_llbc : bool; - (** Pretty-print the LLBC just after we built it (i.e., immediately after - loop reconstruction). *) - print_llbc : bool; - (** Pretty-print the final LLBC (after all the cleaning micro-passes). *) - dest_dir : path_buf option; - (** The destination directory. Files will be generated as - [/.{u}llbc], unless [dest_file] is set. - [dest_dir] defaults to the current directory. *) - dest_file : path_buf option; - (** The destination file. By default [/.llbc]. If - this is set we ignore [dest_dir]. *) - no_dedup_serialized_ast : bool; - (** Don't deduplicate values (types, trait refs) in the .(u)llbc file. - This makes the file easier to inspect. *) - no_serialize : bool; (** Don't serialize the final (U)LLBC to a file. *) - no_typecheck : bool; (** Skip the typecheck passes. *) - no_normalize : bool; (** Don't normalize associated types. *) - abort_on_error : bool; - (** Panic on the first error. This is useful for debugging. *) - error_on_warnings : bool; (** Consider any warnings to be errors. *) - preset : preset option; (** Named builtin sets of options. *) -} - -(** A (group of) top-level declaration(s), properly reordered. *) -and declaration_group = - | TypeGroup of type_decl_id g_declaration_group - (** A type declaration group *) - | FunGroup of fun_decl_id g_declaration_group - (** A function declaration group *) - | GlobalGroup of global_decl_id g_declaration_group - (** A global declaration group *) - | TraitDeclGroup of trait_decl_id g_declaration_group - | TraitImplGroup of trait_impl_id g_declaration_group - | MixedGroup of item_id g_declaration_group - (** Anything that doesn't fit into these categories. *) - -(** A (group of) top-level declaration(s), properly reordered. "G" stands for - "generic" *) -and 'a0 g_declaration_group = - | NonRecGroup of 'a0 (** A non-recursive declaration *) - | RecGroup of 'a0 list (** A (group of mutually) recursive declaration(s) *) - -(** An expression body. TODO: arg_count should be stored in GFunDecl below. But - then, the print is obfuscated and Aeneas may need some refactoring. *) -and 'a0 gexpr_body = { - span : span; - bound_body_regions : int; - (** The number of regions existentially bound in this body. We introduce - fresh such regions during translation instead of the erased regions - that rustc gives us. *) - locals : locals; (** The local variables. *) - body : 'a0; (** The statements and blocks that compose this body. *) -} - -(** The MIR stage to use. This is only relevant for the current crate: for - dependencies, only mir optimized is available (or mir elaborated for - consts). *) -and mir_level = - | Built (** The MIR just after MIR lowering. *) - | Promoted - (** The MIR after const promotion. This is the MIR used by the - borrow-checker. *) - | Elaborated - (** The MIR after drop elaboration. This is the first MIR to include all - the runtime information. *) - | Optimized - (** The MIR after optimizations. Charon disables all the optimizations it - can, so this is sensibly the same MIR as the elaborated MIR. *) - -and monomorphize_mut = - | All (** Monomorphize any item instantiated with [&mut]. *) - | ExceptTypes - (** Monomorphize all non-typedecl items instantiated with [&mut]. *) - -(** Presets to make it easier to tweak options without breaking dependent - projects. Eventually we should define semantically-meaningful presets - instead of project-specific ones. *) -and preset = - | OldDefaults - (** The default translation used before May 2025. After that, many passes - were made optional and disabled by default. *) - | RawMir - (** Emit the MIR as unmodified as possible. This is very imperfect for - now, we should make more passes optional. *) - | Fast (** Skip as many optional transformations as possible. *) - | Aeneas - | Eurydice - | Soteria - | Tests -[@@deriving show] diff --git a/charon-ml/src/generated/Generated_LlbcAst.ml b/charon-ml/src/generated/Generated_LlbcAst.ml index a58c1630c..3ba1eed6b 100644 --- a/charon-ml/src/generated/Generated_LlbcAst.ml +++ b/charon-ml/src/generated/Generated_LlbcAst.ml @@ -1,8 +1,8 @@ -open GAst -open Types -open Values -open Expressions -open Meta +open Generated_GAst +open Generated_Types +open Generated_Values +open Generated_Expressions +open Generated_Meta open Identifiers module StatementId = IdGen () diff --git a/charon-ml/src/generated/Generated_LlbcOfJson.ml b/charon-ml/src/generated/Generated_LlbcOfJson.ml deleted file mode 100644 index a01815d8b..000000000 --- a/charon-ml/src/generated/Generated_LlbcOfJson.ml +++ /dev/null @@ -1,134 +0,0 @@ -open OfJsonBasic -open Types -open LlbcAst -open GAstOfJson - -let rec ___ = () - -and block_of_json (ctx : of_json_ctx) (js : json) : (block, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("span", span); ("statements", statements) ] -> - let* span = span_of_json ctx span in - let* statements = list_of_json statement_of_json ctx statements in - Ok ({ span; statements } : block) - | _ -> Error "") - -and statement_of_json (ctx : of_json_ctx) (js : json) : - (statement, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("span", span); - ("id", id); - ("kind", kind); - ("comments_before", comments_before); - ] -> - let* span = span_of_json ctx span in - let* statement_id = statement_id_of_json ctx id in - let* kind = statement_kind_of_json ctx kind in - let* comments_before = - list_of_json string_of_json ctx comments_before - in - Ok ({ span; statement_id; kind; comments_before } : statement) - | _ -> Error "") - -and statement_id_of_json (ctx : of_json_ctx) (js : json) : - (statement_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | x -> StatementId.id_of_json ctx x - | _ -> Error "") - -and statement_kind_of_json (ctx : of_json_ctx) (js : json) : - (statement_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Assign", `List [ x_0; x_1 ]) ] -> - let* x_0 = place_of_json ctx x_0 in - let* x_1 = rvalue_of_json ctx x_1 in - Ok (Assign (x_0, x_1)) - | `Assoc [ ("SetDiscriminant", `List [ x_0; x_1 ]) ] -> - let* x_0 = place_of_json ctx x_0 in - let* x_1 = variant_id_of_json ctx x_1 in - Ok (SetDiscriminant (x_0, x_1)) - | `Assoc [ ("CopyNonOverlapping", copy_non_overlapping) ] -> - let* copy_non_overlapping = - box_of_json copy_non_overlapping_of_json ctx copy_non_overlapping - in - Ok (CopyNonOverlapping copy_non_overlapping) - | `Assoc [ ("StorageLive", storage_live) ] -> - let* storage_live = local_id_of_json ctx storage_live in - Ok (StorageLive storage_live) - | `Assoc [ ("StorageDead", storage_dead) ] -> - let* storage_dead = local_id_of_json ctx storage_dead in - Ok (StorageDead storage_dead) - | `Assoc [ ("PlaceMention", place_mention) ] -> - let* place_mention = place_of_json ctx place_mention in - Ok (PlaceMention place_mention) - | `Assoc [ ("Drop", `List [ x_0; x_1; x_2 ]) ] -> - let* x_0 = place_of_json ctx x_0 in - let* x_1 = trait_ref_of_json ctx x_1 in - let* x_2 = drop_kind_of_json ctx x_2 in - Ok (Drop (x_0, x_1, x_2)) - | `Assoc - [ - ("Assert", `Assoc [ ("assert", assert_); ("on_failure", on_failure) ]); - ] -> - let* assert_ = assertion_of_json ctx assert_ in - let* on_failure = abort_kind_of_json ctx on_failure in - Ok (Assert (assert_, on_failure)) - | `Assoc [ ("Call", call) ] -> - let* call = call_of_json ctx call in - Ok (Call call) - | `Assoc [ ("Abort", abort) ] -> - let* abort = abort_kind_of_json ctx abort in - Ok (Abort abort) - | `String "Return" -> Ok Return - | `Assoc [ ("Break", break) ] -> - let* break = int_of_json ctx break in - Ok (Break break) - | `Assoc [ ("Continue", continue) ] -> - let* continue = int_of_json ctx continue in - Ok (Continue continue) - | `String "Nop" -> Ok Nop - | `Assoc [ ("Switch", switch) ] -> - let* switch = switch_of_json ctx switch in - Ok (Switch switch) - | `Assoc [ ("Loop", loop) ] -> - let* loop = block_of_json ctx loop in - Ok (Loop loop) - | `Assoc [ ("Error", error) ] -> - let* error = string_of_json ctx error in - Ok (Error error) - | _ -> Error "") - -and switch_of_json (ctx : of_json_ctx) (js : json) : (switch, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("If", `List [ x_0; x_1; x_2 ]) ] -> - let* x_0 = operand_of_json ctx x_0 in - let* x_1 = block_of_json ctx x_1 in - let* x_2 = block_of_json ctx x_2 in - Ok (If (x_0, x_1, x_2)) - | `Assoc [ ("SwitchInt", `List [ x_0; x_1; x_2; x_3 ]) ] -> - let* x_0 = operand_of_json ctx x_0 in - let* x_1 = literal_type_of_json ctx x_1 in - let* x_2 = - list_of_json - (pair_of_json (list_of_json literal_of_json) block_of_json) - ctx x_2 - in - let* x_3 = block_of_json ctx x_3 in - Ok (SwitchInt (x_0, x_1, x_2, x_3)) - | `Assoc [ ("Match", `List [ x_0; x_1; x_2 ]) ] -> - let* x_0 = place_of_json ctx x_0 in - let* x_1 = - list_of_json - (pair_of_json (list_of_json variant_id_of_json) block_of_json) - ctx x_1 - in - let* x_2 = option_of_json block_of_json ctx x_2 in - Ok (Match (x_0, x_1, x_2)) - | _ -> Error "") diff --git a/charon-ml/src/generated/Generated_GAstOfJson.ml b/charon-ml/src/generated/Generated_OfJson.ml similarity index 81% rename from charon-ml/src/generated/Generated_GAstOfJson.ml rename to charon-ml/src/generated/Generated_OfJson.ml index 9b09b7a66..87ef17c4f 100644 --- a/charon-ml/src/generated/Generated_GAstOfJson.ml +++ b/charon-ml/src/generated/Generated_OfJson.ml @@ -1,8 +1,8 @@ -(** WARNING: this file is partially auto-generated. Do not edit `GAstOfJson.ml` - by hand. Edit `GAstOfJson.template.ml` instead, or improve the code - generation tool so avoid the need for hand-writing things. +(** WARNING: this file is partially auto-generated. Do not edit `OfJson.ml` by + hand. Edit `templates/OfJson.ml` instead, or improve the code generation + tool so avoid the need for hand-writing things. - `GAstOfJson.template.ml` contains the manual definitions and some `(* + `templates/OfJson.ml` contains the manual definitions and some `(* __REPLACEn__ *)` comments. These comments are replaced by auto-generated definitions by running `make generate-ml` in the crate root. The code-generation code is in `charon/src/bin/generate-ml`. *) @@ -10,29 +10,35 @@ open Yojson.Basic open OfJsonBasic open Identifiers -open Meta -open Values -open Types +open Generated_Meta +open Generated_Values +open Generated_Types +open Generated_Expressions +open Generated_GAst +open Generated_FullAst open Scalars -open Expressions -open GAst module FileId = IdGen () module HashConsId = IdGen () (** The default logger *) let log = Logging.llbc_of_json_logger -type id_to_file_map = file FileId.Map.t +module FileTbl = Hashtbl.Make (struct + type t = FileId.id + + let equal = FileId.equal_id + let hash = Hashtbl.hash +end) type of_json_ctx = { - id_to_file_map : id_to_file_map; + id_to_file_map : file FileTbl.t; ty_hashcons_map : ty HashConsId.Map.t ref; tref_hashcons_map : trait_ref HashConsId.Map.t ref; } let empty_of_json_ctx : of_json_ctx = { - id_to_file_map = FileId.Map.empty; + id_to_file_map = FileTbl.create 8; ty_hashcons_map = ref HashConsId.Map.empty; tref_hashcons_map = ref HashConsId.Map.empty; } @@ -68,6 +74,16 @@ let big_int_of_json _ (js : json) : (big_int, string) result = | `String is -> Ok (Z.of_string is) | _ -> Error "") +let opt_indexed_map_of_json : + 'a0 'a1. + (of_json_ctx -> json -> ('a0, string) result) -> + (of_json_ctx -> json -> ('a1, string) result) -> + of_json_ctx -> + json -> + ('a1 option list, string) result = + fun arg0_of_json arg1_of_json ctx js -> + list_of_json (option_of_json arg1_of_json) ctx js + let rec ___ = () and abort_kind_of_json (ctx : of_json_ctx) (js : json) : @@ -100,18 +116,6 @@ and aggregate_kind_of_json (ctx : of_json_ctx) (js : json) : Ok (AggregatedRawPtr (x_0, x_1)) | _ -> Error "") -and alignment_modifier_of_json (ctx : of_json_ctx) (js : json) : - (alignment_modifier, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Align", align) ] -> - let* align = int_of_json ctx align in - Ok (Align align) - | `Assoc [ ("Pack", pack) ] -> - let* pack = int_of_json ctx pack in - Ok (Pack pack) - | _ -> Error "") - and assertion_of_json (ctx : of_json_ctx) (js : json) : (assertion, string) result = combine_error_msgs js __FUNCTION__ @@ -127,47 +131,6 @@ and assertion_of_json (ctx : of_json_ctx) (js : json) : Ok ({ cond; expected; check_kind } : assertion) | _ -> Error "") -and attr_info_of_json (ctx : of_json_ctx) (js : json) : - (attr_info, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("attributes", attributes); - ("inline", inline); - ("rename", rename); - ("public", public); - ] -> - let* attributes = list_of_json attribute_of_json ctx attributes in - let* inline = option_of_json inline_attr_of_json ctx inline in - let* rename = option_of_json string_of_json ctx rename in - let* public = bool_of_json ctx public in - Ok ({ attributes; inline; rename; public } : attr_info) - | _ -> Error "") - -and attribute_of_json (ctx : of_json_ctx) (js : json) : - (attribute, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Opaque" -> Ok AttrOpaque - | `String "Exclude" -> Ok AttrExclude - | `Assoc [ ("Rename", rename) ] -> - let* rename = string_of_json ctx rename in - Ok (AttrRename rename) - | `Assoc [ ("VariantsPrefix", variants_prefix) ] -> - let* variants_prefix = string_of_json ctx variants_prefix in - Ok (AttrVariantsPrefix variants_prefix) - | `Assoc [ ("VariantsSuffix", variants_suffix) ] -> - let* variants_suffix = string_of_json ctx variants_suffix in - Ok (AttrVariantsSuffix variants_suffix) - | `Assoc [ ("DocComment", doc_comment) ] -> - let* doc_comment = string_of_json ctx doc_comment in - Ok (AttrDocComment doc_comment) - | `Assoc [ ("Unknown", unknown) ] -> - let* unknown = raw_attribute_of_json ctx unknown in - Ok (AttrUnknown unknown) - | _ -> Error "") - and binop_of_json (ctx : of_json_ctx) (js : json) : (binop, string) result = combine_error_msgs js __FUNCTION__ (match js with @@ -403,224 +366,22 @@ and cast_kind_of_json (ctx : of_json_ctx) (js : json) : Ok (CastConcretize (x_0, x_1)) | _ -> Error "") -and cli_options_of_json (ctx : of_json_ctx) (js : json) : - (cli_options, string) result = +and const_generic_param_of_json (ctx : of_json_ctx) (js : json) : + (const_generic_param, string) result = combine_error_msgs js __FUNCTION__ (match js with - | `Assoc - [ - ("ullbc", ullbc); - ("precise_drops", precise_drops); - ("skip_borrowck", skip_borrowck); - ("mir", mir); - ("rustc_args", rustc_args); - ("targets", targets); - ("monomorphize", monomorphize); - ("monomorphize_mut", monomorphize_mut); - ("start_from", start_from); - ("start_from_if_exists", start_from_if_exists); - ("start_from_attribute", start_from_attribute); - ("start_from_pub", start_from_pub); - ("include", include_); - ("opaque", opaque); - ("exclude", exclude); - ("extract_opaque_bodies", extract_opaque_bodies); - ("translate_all_methods", translate_all_methods); - ("lift_associated_types", lift_associated_types); - ("hide_marker_traits", hide_marker_traits); - ("remove_adt_clauses", remove_adt_clauses); - ("hide_allocator", hide_allocator); - ("remove_unused_self_clauses", remove_unused_self_clauses); - ("desugar_drops", desugar_drops); - ("ops_to_function_calls", ops_to_function_calls); - ("index_to_function_calls", index_to_function_calls); - ("treat_box_as_builtin", treat_box_as_builtin); - ("raw_consts", raw_consts); - ("unsized_strings", unsized_strings); - ("reconstruct_fallible_operations", reconstruct_fallible_operations); - ("reconstruct_asserts", reconstruct_asserts); - ("unbind_item_vars", unbind_item_vars); - ("print_original_ullbc", print_original_ullbc); - ("print_ullbc", print_ullbc); - ("print_built_llbc", print_built_llbc); - ("print_llbc", print_llbc); - ("dest_dir", dest_dir); - ("dest_file", dest_file); - ("no_dedup_serialized_ast", no_dedup_serialized_ast); - ("no_serialize", no_serialize); - ("no_typecheck", no_typecheck); - ("no_normalize", no_normalize); - ("abort_on_error", abort_on_error); - ("error_on_warnings", error_on_warnings); - ("preset", preset); - ] -> - let* ullbc = bool_of_json ctx ullbc in - let* precise_drops = bool_of_json ctx precise_drops in - let* skip_borrowck = bool_of_json ctx skip_borrowck in - let* mir = option_of_json mir_level_of_json ctx mir in - let* rustc_args = list_of_json string_of_json ctx rustc_args in - let* targets = list_of_json string_of_json ctx targets in - let* monomorphize = bool_of_json ctx monomorphize in - let* monomorphize_mut = - option_of_json monomorphize_mut_of_json ctx monomorphize_mut - in - let* start_from = list_of_json string_of_json ctx start_from in - let* start_from_if_exists = - list_of_json string_of_json ctx start_from_if_exists - in - let* start_from_attribute = - option_of_json string_of_json ctx start_from_attribute - in - let* start_from_pub = bool_of_json ctx start_from_pub in - let* included = list_of_json string_of_json ctx include_ in - let* opaque = list_of_json string_of_json ctx opaque in - let* exclude = list_of_json string_of_json ctx exclude in - let* extract_opaque_bodies = bool_of_json ctx extract_opaque_bodies in - let* translate_all_methods = bool_of_json ctx translate_all_methods in - let* lift_associated_types = - list_of_json string_of_json ctx lift_associated_types - in - let* hide_marker_traits = bool_of_json ctx hide_marker_traits in - let* remove_adt_clauses = bool_of_json ctx remove_adt_clauses in - let* hide_allocator = bool_of_json ctx hide_allocator in - let* remove_unused_self_clauses = - bool_of_json ctx remove_unused_self_clauses - in - let* desugar_drops = bool_of_json ctx desugar_drops in - let* ops_to_function_calls = bool_of_json ctx ops_to_function_calls in - let* index_to_function_calls = - bool_of_json ctx index_to_function_calls - in - let* treat_box_as_builtin = bool_of_json ctx treat_box_as_builtin in - let* raw_consts = bool_of_json ctx raw_consts in - let* unsized_strings = bool_of_json ctx unsized_strings in - let* reconstruct_fallible_operations = - bool_of_json ctx reconstruct_fallible_operations - in - let* reconstruct_asserts = bool_of_json ctx reconstruct_asserts in - let* unbind_item_vars = bool_of_json ctx unbind_item_vars in - let* print_original_ullbc = bool_of_json ctx print_original_ullbc in - let* print_ullbc = bool_of_json ctx print_ullbc in - let* print_built_llbc = bool_of_json ctx print_built_llbc in - let* print_llbc = bool_of_json ctx print_llbc in - let* dest_dir = option_of_json path_buf_of_json ctx dest_dir in - let* dest_file = option_of_json path_buf_of_json ctx dest_file in - let* no_dedup_serialized_ast = - bool_of_json ctx no_dedup_serialized_ast - in - let* no_serialize = bool_of_json ctx no_serialize in - let* no_typecheck = bool_of_json ctx no_typecheck in - let* no_normalize = bool_of_json ctx no_normalize in - let* abort_on_error = bool_of_json ctx abort_on_error in - let* error_on_warnings = bool_of_json ctx error_on_warnings in - let* preset = option_of_json preset_of_json ctx preset in - Ok - ({ - ullbc; - precise_drops; - skip_borrowck; - mir; - rustc_args; - targets; - monomorphize; - monomorphize_mut; - start_from; - start_from_if_exists; - start_from_attribute; - start_from_pub; - included; - opaque; - exclude; - extract_opaque_bodies; - translate_all_methods; - lift_associated_types; - hide_marker_traits; - remove_adt_clauses; - hide_allocator; - remove_unused_self_clauses; - desugar_drops; - ops_to_function_calls; - index_to_function_calls; - treat_box_as_builtin; - raw_consts; - unsized_strings; - reconstruct_fallible_operations; - reconstruct_asserts; - unbind_item_vars; - print_original_ullbc; - print_ullbc; - print_built_llbc; - print_llbc; - dest_dir; - dest_file; - no_dedup_serialized_ast; - no_serialize; - no_typecheck; - no_normalize; - abort_on_error; - error_on_warnings; - preset; - } - : cli_options) + | `Assoc [ ("index", index); ("name", name); ("ty", ty) ] -> + let* index = const_generic_var_id_of_json ctx index in + let* name = string_of_json ctx name in + let* ty = ty_of_json ctx ty in + Ok ({ index; name; ty } : const_generic_param) | _ -> Error "") -and closure_info_of_json (ctx : of_json_ctx) (js : json) : - (closure_info, string) result = +and const_generic_var_id_of_json (ctx : of_json_ctx) (js : json) : + (const_generic_var_id, string) result = combine_error_msgs js __FUNCTION__ (match js with - | `Assoc - [ - ("kind", kind); - ("fn_once_impl", fn_once_impl); - ("fn_mut_impl", fn_mut_impl); - ("fn_impl", fn_impl); - ("signature", signature); - ] -> - let* kind = closure_kind_of_json ctx kind in - let* fn_once_impl = - region_binder_of_json trait_impl_ref_of_json ctx fn_once_impl - in - let* fn_mut_impl = - option_of_json - (region_binder_of_json trait_impl_ref_of_json) - ctx fn_mut_impl - in - let* fn_impl = - option_of_json - (region_binder_of_json trait_impl_ref_of_json) - ctx fn_impl - in - let* signature = region_binder_of_json fun_sig_of_json ctx signature in - Ok - ({ kind; fn_once_impl; fn_mut_impl; fn_impl; signature } - : closure_info) - | _ -> Error "") - -and closure_kind_of_json (ctx : of_json_ctx) (js : json) : - (closure_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Fn" -> Ok Fn - | `String "FnMut" -> Ok FnMut - | `String "FnOnce" -> Ok FnOnce - | _ -> Error "") - -and const_generic_param_of_json (ctx : of_json_ctx) (js : json) : - (const_generic_param, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("index", index); ("name", name); ("ty", ty) ] -> - let* index = const_generic_var_id_of_json ctx index in - let* name = string_of_json ctx name in - let* ty = ty_of_json ctx ty in - Ok ({ index; name; ty } : const_generic_param) - | _ -> Error "") - -and const_generic_var_id_of_json (ctx : of_json_ctx) (js : json) : - (const_generic_var_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | x -> ConstGenericVarId.id_of_json ctx x + | x -> ConstGenericVarId.id_of_json ctx x | _ -> Error "") and constant_expr_of_json (ctx : of_json_ctx) (js : json) : @@ -722,38 +483,6 @@ and de_bruijn_var_of_json : Ok (Free free) | _ -> Error "") -and declaration_group_of_json (ctx : of_json_ctx) (js : json) : - (declaration_group, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Type", type_) ] -> - let* type_ = - g_declaration_group_of_json type_decl_id_of_json ctx type_ - in - Ok (TypeGroup type_) - | `Assoc [ ("Fun", fun_) ] -> - let* fun_ = g_declaration_group_of_json fun_decl_id_of_json ctx fun_ in - Ok (FunGroup fun_) - | `Assoc [ ("Global", global) ] -> - let* global = - g_declaration_group_of_json global_decl_id_of_json ctx global - in - Ok (GlobalGroup global) - | `Assoc [ ("TraitDecl", trait_decl) ] -> - let* trait_decl = - g_declaration_group_of_json trait_decl_id_of_json ctx trait_decl - in - Ok (TraitDeclGroup trait_decl) - | `Assoc [ ("TraitImpl", trait_impl) ] -> - let* trait_impl = - g_declaration_group_of_json trait_impl_id_of_json ctx trait_impl - in - Ok (TraitImplGroup trait_impl) - | `Assoc [ ("Mixed", mixed) ] -> - let* mixed = g_declaration_group_of_json item_id_of_json ctx mixed in - Ok (MixedGroup mixed) - | _ -> Error "") - and disambiguator_of_json (ctx : of_json_ctx) (js : json) : (disambiguator, string) result = combine_error_msgs js __FUNCTION__ @@ -761,18 +490,6 @@ and disambiguator_of_json (ctx : of_json_ctx) (js : json) : | x -> Disambiguator.id_of_json ctx x | _ -> Error "") -and discriminant_layout_of_json (ctx : of_json_ctx) (js : json) : - (discriminant_layout, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("offset", offset); ("tag_ty", tag_ty); ("encoding", encoding) ] - -> - let* offset = int_of_json ctx offset in - let* tag_ty = integer_type_of_json ctx tag_ty in - let* encoding = tag_encoding_of_json ctx encoding in - Ok ({ offset; tag_ty; encoding } : discriminant_layout) - | _ -> Error "") - and drop_kind_of_json (ctx : of_json_ctx) (js : json) : (drop_kind, string) result = combine_error_msgs js __FUNCTION__ @@ -790,28 +507,6 @@ and dyn_predicate_of_json (ctx : of_json_ctx) (js : json) : Ok ({ binder } : dyn_predicate) | _ -> Error "") -and error_of_json (ctx : of_json_ctx) (js : json) : (error, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("span", span); ("msg", msg) ] -> - let* span = span_of_json ctx span in - let* msg = string_of_json ctx msg in - Ok ({ span; msg } : error) - | _ -> Error "") - -and field_of_json (ctx : of_json_ctx) (js : json) : (field, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ ("span", span); ("attr_info", attr_info); ("name", name); ("ty", ty) ] - -> - let* span = span_of_json ctx span in - let* attr_info = attr_info_of_json ctx attr_info in - let* field_name = option_of_json string_of_json ctx name in - let* field_ty = ty_of_json ctx ty in - Ok ({ span; attr_info; field_name; field_ty } : field) - | _ -> Error "") - and field_id_of_json (ctx : of_json_ctx) (js : json) : (field_id, string) result = combine_error_msgs js __FUNCTION__ @@ -832,42 +527,15 @@ and field_proj_kind_of_json (ctx : of_json_ctx) (js : json) : Ok (ProjTuple tuple) | _ -> Error "") -and file_of_json (ctx : of_json_ctx) (js : json) : (file, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ ("name", name); ("crate_name", crate_name); ("contents", contents) ] - -> - let* name = file_name_of_json ctx name in - let* crate_name = string_of_json ctx crate_name in - let* contents = option_of_json string_of_json ctx contents in - Ok ({ name; crate_name; contents } : file) - | _ -> Error "") - and file_id_of_json (ctx : of_json_ctx) (js : json) : (file_id, string) result = combine_error_msgs js __FUNCTION__ (match js with | json -> let* file_id = FileId.id_of_json ctx json in - let file = FileId.Map.find file_id ctx.id_to_file_map in + let file = FileTbl.find ctx.id_to_file_map file_id in Ok file | _ -> Error "") -and file_name_of_json (ctx : of_json_ctx) (js : json) : - (file_name, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Virtual", virtual_) ] -> - let* virtual_ = path_buf_of_json ctx virtual_ in - Ok (Virtual virtual_) - | `Assoc [ ("Local", local) ] -> - let* local = path_buf_of_json ctx local in - Ok (Local local) - | `Assoc [ ("NotReal", not_real) ] -> - let* not_real = string_of_json ctx not_real in - Ok (NotReal not_real) - | _ -> Error "") - and float_type_of_json (ctx : of_json_ctx) (js : json) : (float_type, string) result = combine_error_msgs js __FUNCTION__ @@ -962,47 +630,6 @@ and fun_sig_of_json (ctx : of_json_ctx) (js : json) : (fun_sig, string) result = Ok ({ is_unsafe; inputs; output } : fun_sig) | _ -> Error "") -and g_declaration_group_of_json : - 'a0. - (of_json_ctx -> json -> ('a0, string) result) -> - of_json_ctx -> - json -> - ('a0 g_declaration_group, string) result = - fun arg0_of_json ctx js -> - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("NonRec", non_rec) ] -> - let* non_rec = arg0_of_json ctx non_rec in - Ok (NonRecGroup non_rec) - | `Assoc [ ("Rec", rec_) ] -> - let* rec_ = list_of_json arg0_of_json ctx rec_ in - Ok (RecGroup rec_) - | _ -> Error "") - -and gexpr_body_of_json : - 'a0. - (of_json_ctx -> json -> ('a0, string) result) -> - of_json_ctx -> - json -> - ('a0 gexpr_body, string) result = - fun arg0_of_json ctx js -> - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("span", span); - ("bound_body_regions", bound_body_regions); - ("locals", locals); - ("body", body); - ("comments", _); - ] -> - let* span = span_of_json ctx span in - let* bound_body_regions = int_of_json ctx bound_body_regions in - let* locals = locals_of_json ctx locals in - let* body = arg0_of_json ctx body in - Ok ({ span; bound_body_regions; locals; body } : _ gexpr_body) - | _ -> Error "") - and generic_args_of_json (ctx : of_json_ctx) (js : json) : (generic_args, string) result = combine_error_msgs js __FUNCTION__ @@ -1089,32 +716,6 @@ and generic_params_of_json (ctx : of_json_ctx) (js : json) : : generic_params) | _ -> Error "") -and global_decl_of_json (ctx : of_json_ctx) (js : json) : - (global_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("item_meta", item_meta); - ("generics", generics); - ("ty", ty); - ("src", src); - ("global_kind", global_kind); - ("init", init); - ] -> - let* def_id = global_decl_id_of_json ctx def_id in - let* item_meta = item_meta_of_json ctx item_meta in - let* generics = generic_params_of_json ctx generics in - let* ty = ty_of_json ctx ty in - let* src = item_source_of_json ctx src in - let* global_kind = global_kind_of_json ctx global_kind in - let* init = fun_decl_id_of_json ctx init in - Ok - ({ def_id; item_meta; generics; ty; src; global_kind; init } - : global_decl) - | _ -> Error "") - and global_decl_id_of_json (ctx : of_json_ctx) (js : json) : (global_decl_id, string) result = combine_error_msgs js __FUNCTION__ @@ -1132,15 +733,6 @@ and global_decl_ref_of_json (ctx : of_json_ctx) (js : json) : Ok ({ id; generics } : global_decl_ref) | _ -> Error "") -and global_kind_of_json (ctx : of_json_ctx) (js : json) : - (global_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Static" -> Ok Static - | `String "NamedConst" -> Ok NamedConst - | `String "AnonConst" -> Ok AnonConst - | _ -> Error "") - and hash_consed_of_json : 'a0. (of_json_ctx -> json -> ('a0, string) result) -> @@ -1165,36 +757,6 @@ and impl_elem_of_json (ctx : of_json_ctx) (js : json) : Ok (ImplElemTrait trait) | _ -> Error "") -and index_map_of_json : - 'a0 'a1 'a2. - (of_json_ctx -> json -> ('a0, string) result) -> - (of_json_ctx -> json -> ('a1, string) result) -> - (of_json_ctx -> json -> ('a2, string) result) -> - of_json_ctx -> - json -> - (('a0 * 'a1) list, string) result = - fun arg0_of_json arg1_of_json arg2_of_json ctx js -> - combine_error_msgs js __FUNCTION__ - (match js with - | json -> - list_of_json (key_value_pair_of_json arg0_of_json arg1_of_json) ctx json - | _ -> Error "") - -and indexed_map_of_json : - 'a0 'a1. - (of_json_ctx -> json -> ('a0, string) result) -> - (of_json_ctx -> json -> ('a1, string) result) -> - of_json_ctx -> - json -> - ('a1 list, string) result = - fun arg0_of_json arg1_of_json ctx js -> - combine_error_msgs js __FUNCTION__ - (match js with - | json -> - let* list = list_of_json (option_of_json arg1_of_json) ctx json in - Ok (List.filter_map (fun x -> x) list) - | _ -> Error "") - and index_vec_of_json : 'a0 'a1. (of_json_ctx -> json -> ('a0, string) result) -> @@ -1208,15 +770,6 @@ and index_vec_of_json : | json -> list_of_json arg1_of_json ctx json | _ -> Error "") -and inline_attr_of_json (ctx : of_json_ctx) (js : json) : - (inline_attr, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Hint" -> Ok Hint - | `String "Never" -> Ok Never - | `String "Always" -> Ok Always - | _ -> Error "") - and int_ty_of_json (ctx : of_json_ctx) (js : json) : (int_ty, string) result = combine_error_msgs js __FUNCTION__ (match js with @@ -1228,169 +781,16 @@ and int_ty_of_json (ctx : of_json_ctx) (js : json) : (int_ty, string) result = | `String "I128" -> Ok I128 | _ -> Error "") -and integer_type_of_json (ctx : of_json_ctx) (js : json) : - (integer_type, string) result = +and lifetime_mutability_of_json (ctx : of_json_ctx) (js : json) : + (lifetime_mutability, string) result = combine_error_msgs js __FUNCTION__ (match js with - | `Assoc [ ("Signed", signed) ] -> - let* signed = int_ty_of_json ctx signed in - Ok (Signed signed) - | `Assoc [ ("Unsigned", unsigned) ] -> - let* unsigned = u_int_ty_of_json ctx unsigned in - Ok (Unsigned unsigned) + | `String "Mutable" -> Ok LtMutable + | `String "Shared" -> Ok LtShared + | `String "Unknown" -> Ok LtUnknown | _ -> Error "") -and item_id_of_json (ctx : of_json_ctx) (js : json) : (item_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Type", type_) ] -> - let* type_ = type_decl_id_of_json ctx type_ in - Ok (IdType type_) - | `Assoc [ ("TraitDecl", trait_decl) ] -> - let* trait_decl = trait_decl_id_of_json ctx trait_decl in - Ok (IdTraitDecl trait_decl) - | `Assoc [ ("TraitImpl", trait_impl) ] -> - let* trait_impl = trait_impl_id_of_json ctx trait_impl in - Ok (IdTraitImpl trait_impl) - | `Assoc [ ("Fun", fun_) ] -> - let* fun_ = fun_decl_id_of_json ctx fun_ in - Ok (IdFun fun_) - | `Assoc [ ("Global", global) ] -> - let* global = global_decl_id_of_json ctx global in - Ok (IdGlobal global) - | _ -> Error "") - -and item_meta_of_json (ctx : of_json_ctx) (js : json) : - (item_meta, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("name", name); - ("span", span); - ("source_text", source_text); - ("attr_info", attr_info); - ("is_local", is_local); - ("opacity", _); - ("lang_item", lang_item); - ] -> - let* name = name_of_json ctx name in - let* span = span_of_json ctx span in - let* source_text = option_of_json string_of_json ctx source_text in - let* attr_info = attr_info_of_json ctx attr_info in - let* is_local = bool_of_json ctx is_local in - let* lang_item = option_of_json string_of_json ctx lang_item in - Ok - ({ name; span; source_text; attr_info; is_local; lang_item } - : item_meta) - | _ -> Error "") - -and item_source_of_json (ctx : of_json_ctx) (js : json) : - (item_source, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "TopLevel" -> Ok TopLevelItem - | `Assoc [ ("Closure", `Assoc [ ("info", info) ]) ] -> - let* info = closure_info_of_json ctx info in - Ok (ClosureItem info) - | `Assoc - [ - ( "TraitDecl", - `Assoc - [ - ("trait_ref", trait_ref); - ("item_name", item_name); - ("has_default", has_default); - ] ); - ] -> - let* trait_ref = trait_decl_ref_of_json ctx trait_ref in - let* item_name = trait_item_name_of_json ctx item_name in - let* has_default = bool_of_json ctx has_default in - Ok (TraitDeclItem (trait_ref, item_name, has_default)) - | `Assoc - [ - ( "TraitImpl", - `Assoc - [ - ("impl_ref", impl_ref); - ("trait_ref", trait_ref); - ("item_name", item_name); - ("reuses_default", reuses_default); - ] ); - ] -> - let* impl_ref = trait_impl_ref_of_json ctx impl_ref in - let* trait_ref = trait_decl_ref_of_json ctx trait_ref in - let* item_name = trait_item_name_of_json ctx item_name in - let* reuses_default = bool_of_json ctx reuses_default in - Ok (TraitImplItem (impl_ref, trait_ref, item_name, reuses_default)) - | `Assoc - [ - ( "VTableTy", - `Assoc - [ - ("dyn_predicate", dyn_predicate); - ("field_map", field_map); - ("supertrait_map", supertrait_map); - ] ); - ] -> - let* dyn_predicate = dyn_predicate_of_json ctx dyn_predicate in - let* field_map = - index_vec_of_json field_id_of_json v_table_field_of_json ctx field_map - in - let* supertrait_map = - index_vec_of_json trait_clause_id_of_json - (option_of_json field_id_of_json) - ctx supertrait_map - in - Ok (VTableTyItem (dyn_predicate, field_map, supertrait_map)) - | `Assoc [ ("VTableInstance", `Assoc [ ("impl_ref", impl_ref) ]) ] -> - let* impl_ref = trait_impl_ref_of_json ctx impl_ref in - Ok (VTableInstanceItem impl_ref) - | `String "VTableMethodShim" -> Ok VTableMethodShimItem - | `String "VTableInstanceMono" -> Ok VTableInstanceMonoItem - | `Assoc [ ("VTableMethodPreShim", `List [ x_0; x_1; x_2 ]) ] -> - let* x_0 = trait_decl_id_of_json ctx x_0 in - let* x_1 = trait_item_name_of_json ctx x_1 in - let* x_2 = list_of_json ty_of_json ctx x_2 in - Ok (VTableMethodPreShimItem (x_0, x_1, x_2)) - | _ -> Error "") - -and layout_of_json (ctx : of_json_ctx) (js : json) : (layout, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("size", size); - ("align", align); - ("discriminant_layout", discriminant_layout); - ("uninhabited", uninhabited); - ("variant_layouts", variant_layouts); - ] -> - let* size = option_of_json int_of_json ctx size in - let* align = option_of_json int_of_json ctx align in - let* discriminant_layout = - option_of_json discriminant_layout_of_json ctx discriminant_layout - in - let* uninhabited = bool_of_json ctx uninhabited in - let* variant_layouts = - index_vec_of_json variant_id_of_json variant_layout_of_json ctx - variant_layouts - in - Ok - ({ size; align; discriminant_layout; uninhabited; variant_layouts } - : layout) - | _ -> Error "") - -and lifetime_mutability_of_json (ctx : of_json_ctx) (js : json) : - (lifetime_mutability, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Mutable" -> Ok LtMutable - | `String "Shared" -> Ok LtShared - | `String "Unknown" -> Ok LtUnknown - | _ -> Error "") - -and literal_of_json (ctx : of_json_ctx) (js : json) : (literal, string) result = +and literal_of_json (ctx : of_json_ctx) (js : json) : (literal, string) result = combine_error_msgs js __FUNCTION__ (match js with | `Assoc [ ("Scalar", scalar) ] -> @@ -1439,17 +839,6 @@ and loc_of_json (ctx : of_json_ctx) (js : json) : (loc, string) result = Ok ({ line; col } : loc) | _ -> Error "") -and local_of_json (ctx : of_json_ctx) (js : json) : (local, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("index", index); ("name", name); ("span", span); ("ty", ty) ] -> - let* index = local_id_of_json ctx index in - let* name = option_of_json string_of_json ctx name in - let* span = span_of_json ctx span in - let* local_ty = ty_of_json ctx ty in - Ok ({ index; name; span; local_ty } : local) - | _ -> Error "") - and local_id_of_json (ctx : of_json_ctx) (js : json) : (local_id, string) result = combine_error_msgs js __FUNCTION__ @@ -1457,35 +846,6 @@ and local_id_of_json (ctx : of_json_ctx) (js : json) : (local_id, string) result | x -> LocalId.id_of_json ctx x | _ -> Error "") -and locals_of_json (ctx : of_json_ctx) (js : json) : (locals, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("arg_count", arg_count); ("locals", locals) ] -> - let* arg_count = int_of_json ctx arg_count in - let* locals = - index_vec_of_json local_id_of_json local_of_json ctx locals - in - Ok ({ arg_count; locals } : locals) - | _ -> Error "") - -and mir_level_of_json (ctx : of_json_ctx) (js : json) : - (mir_level, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Built" -> Ok Built - | `String "Promoted" -> Ok Promoted - | `String "Elaborated" -> Ok Elaborated - | `String "Optimized" -> Ok Optimized - | _ -> Error "") - -and monomorphize_mut_of_json (ctx : of_json_ctx) (js : json) : - (monomorphize_mut, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "All" -> Ok All - | `String "ExceptTypes" -> Ok ExceptTypes - | _ -> Error "") - and name_of_json (ctx : of_json_ctx) (js : json) : (name, string) result = combine_error_msgs js __FUNCTION__ (match js with @@ -1592,16 +952,19 @@ and place_kind_of_json (ctx : of_json_ctx) (js : json) : Ok (PlaceGlobal global) | _ -> Error "") -and preset_of_json (ctx : of_json_ctx) (js : json) : (preset, string) result = +and predicate_origin_of_json (ctx : of_json_ctx) (js : json) : + (predicate_origin, string) result = combine_error_msgs js __FUNCTION__ (match js with - | `String "OldDefaults" -> Ok OldDefaults - | `String "RawMir" -> Ok RawMir - | `String "Fast" -> Ok Fast - | `String "Aeneas" -> Ok Aeneas - | `String "Eurydice" -> Ok Eurydice - | `String "Soteria" -> Ok Soteria - | `String "Tests" -> Ok Tests + | `String "WhereClauseOnFn" -> Ok WhereClauseOnFn + | `String "WhereClauseOnType" -> Ok WhereClauseOnType + | `String "WhereClauseOnImpl" -> Ok WhereClauseOnImpl + | `String "TraitSelf" -> Ok TraitSelf + | `String "WhereClauseOnTrait" -> Ok WhereClauseOnTrait + | `Assoc [ ("TraitItem", trait_item) ] -> + let* trait_item = trait_item_name_of_json ctx trait_item in + Ok (TraitItem trait_item) + | `String "Dyn" -> Ok OriginDyn | _ -> Error "") and projection_elem_of_json (ctx : of_json_ctx) (js : json) : @@ -1643,30 +1006,6 @@ and provenance_of_json (ctx : of_json_ctx) (js : json) : | `String "Unknown" -> Ok ProvUnknown | _ -> Error "") -and ptr_metadata_of_json (ctx : of_json_ctx) (js : json) : - (ptr_metadata, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "None" -> Ok NoMetadata - | `String "Length" -> Ok Length - | `Assoc [ ("VTable", v_table) ] -> - let* v_table = type_decl_ref_of_json ctx v_table in - Ok (VTable v_table) - | `Assoc [ ("InheritFrom", inherit_from) ] -> - let* inherit_from = ty_of_json ctx inherit_from in - Ok (InheritFrom inherit_from) - | _ -> Error "") - -and raw_attribute_of_json (ctx : of_json_ctx) (js : json) : - (raw_attribute, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("path", path); ("args", args) ] -> - let* path = string_of_json ctx path in - let* args = option_of_json string_of_json ctx args in - Ok ({ path; args } : raw_attribute) - | _ -> Error "") - and ref_kind_of_json (ctx : of_json_ctx) (js : json) : (ref_kind, string) result = combine_error_msgs js __FUNCTION__ @@ -1723,36 +1062,6 @@ and region_param_of_json (ctx : of_json_ctx) (js : json) : Ok ({ index; name; mutability } : region_param) | _ -> Error "") -and repr_algorithm_of_json (ctx : of_json_ctx) (js : json) : - (repr_algorithm, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `String "Rust" -> Ok Rust - | `String "C" -> Ok C - | _ -> Error "") - -and repr_options_of_json (ctx : of_json_ctx) (js : json) : - (repr_options, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("repr_algo", repr_algo); - ("align_modif", align_modif); - ("transparent", transparent); - ("explicit_discr_type", explicit_discr_type); - ] -> - let* repr_algo = repr_algorithm_of_json ctx repr_algo in - let* align_modif = - option_of_json alignment_modifier_of_json ctx align_modif - in - let* transparent = bool_of_json ctx transparent in - let* explicit_discr_type = bool_of_json ctx explicit_discr_type in - Ok - ({ repr_algo; align_modif; transparent; explicit_discr_type } - : repr_options) - | _ -> Error "") - and rvalue_of_json (ctx : of_json_ctx) (js : json) : (rvalue, string) result = combine_error_msgs js __FUNCTION__ (match js with @@ -1855,129 +1164,22 @@ and span_data_of_json (ctx : of_json_ctx) (js : json) : Ok ({ file; beg_loc; end_loc } : span_data) | _ -> Error "") -and tag_encoding_of_json (ctx : of_json_ctx) (js : json) : - (tag_encoding, string) result = +and trait_assoc_ty_impl_of_json (ctx : of_json_ctx) (js : json) : + (trait_assoc_ty_impl, string) result = combine_error_msgs js __FUNCTION__ (match js with - | `String "Direct" -> Ok Direct - | `Assoc [ ("Niche", `Assoc [ ("untagged_variant", untagged_variant) ]) ] -> - let* untagged_variant = variant_id_of_json ctx untagged_variant in - Ok (Niche untagged_variant) + | `Assoc [ ("value", value); ("implied_trait_refs", _) ] -> + let* value = ty_of_json ctx value in + Ok ({ value } : trait_assoc_ty_impl) | _ -> Error "") -and target_info_of_json (ctx : of_json_ctx) (js : json) : - (target_info, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("target_pointer_size", target_pointer_size); - ("is_little_endian", is_little_endian); - ] -> - let* target_pointer_size = int_of_json ctx target_pointer_size in - let* is_little_endian = bool_of_json ctx is_little_endian in - Ok ({ target_pointer_size; is_little_endian } : target_info) - | _ -> Error "") - -and trait_assoc_const_of_json (ctx : of_json_ctx) (js : json) : - (trait_assoc_const, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("name", name); - ("attr_info", attr_info); - ("ty", ty); - ("default", default); - ] -> - let* name = trait_item_name_of_json ctx name in - let* attr_info = attr_info_of_json ctx attr_info in - let* ty = ty_of_json ctx ty in - let* default = option_of_json global_decl_ref_of_json ctx default in - Ok ({ name; attr_info; ty; default } : trait_assoc_const) - | _ -> Error "") - -and trait_assoc_ty_of_json (ctx : of_json_ctx) (js : json) : - (trait_assoc_ty, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("name", name); - ("attr_info", attr_info); - ("default", default); - ("implied_clauses", implied_clauses); - ] -> - let* name = trait_item_name_of_json ctx name in - let* attr_info = attr_info_of_json ctx attr_info in - let* default = option_of_json trait_assoc_ty_impl_of_json ctx default in - let* implied_clauses = - index_vec_of_json trait_clause_id_of_json trait_param_of_json ctx - implied_clauses - in - Ok ({ name; attr_info; default; implied_clauses } : trait_assoc_ty) - | _ -> Error "") - -and trait_assoc_ty_impl_of_json (ctx : of_json_ctx) (js : json) : - (trait_assoc_ty_impl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("value", value); ("implied_trait_refs", _) ] -> - let* value = ty_of_json ctx value in - Ok ({ value } : trait_assoc_ty_impl) - | _ -> Error "") - -and trait_clause_id_of_json (ctx : of_json_ctx) (js : json) : - (trait_clause_id, string) result = +and trait_clause_id_of_json (ctx : of_json_ctx) (js : json) : + (trait_clause_id, string) result = combine_error_msgs js __FUNCTION__ (match js with | x -> TraitClauseId.id_of_json ctx x | _ -> Error "") -and trait_decl_of_json (ctx : of_json_ctx) (js : json) : - (trait_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("item_meta", item_meta); - ("generics", generics); - ("implied_clauses", implied_clauses); - ("consts", consts); - ("types", types); - ("methods", methods); - ("vtable", vtable); - ] -> - let* def_id = trait_decl_id_of_json ctx def_id in - let* item_meta = item_meta_of_json ctx item_meta in - let* generics = generic_params_of_json ctx generics in - let* implied_clauses = - index_vec_of_json trait_clause_id_of_json trait_param_of_json ctx - implied_clauses - in - let* consts = list_of_json trait_assoc_const_of_json ctx consts in - let* types = - list_of_json (binder_of_json trait_assoc_ty_of_json) ctx types - in - let* methods = - list_of_json (binder_of_json trait_method_of_json) ctx methods - in - let* vtable = option_of_json type_decl_ref_of_json ctx vtable in - Ok - ({ - def_id; - item_meta; - generics; - implied_clauses; - consts; - types; - methods; - vtable; - } - : trait_decl) - | _ -> Error "") - and trait_decl_id_of_json (ctx : of_json_ctx) (js : json) : (trait_decl_id, string) result = combine_error_msgs js __FUNCTION__ @@ -1995,63 +1197,6 @@ and trait_decl_ref_of_json (ctx : of_json_ctx) (js : json) : Ok ({ id; generics } : trait_decl_ref) | _ -> Error "") -and trait_impl_of_json (ctx : of_json_ctx) (js : json) : - (trait_impl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("item_meta", item_meta); - ("impl_trait", impl_trait); - ("generics", generics); - ("implied_trait_refs", implied_trait_refs); - ("consts", consts); - ("types", types); - ("methods", methods); - ("vtable", vtable); - ] -> - let* def_id = trait_impl_id_of_json ctx def_id in - let* item_meta = item_meta_of_json ctx item_meta in - let* impl_trait = trait_decl_ref_of_json ctx impl_trait in - let* generics = generic_params_of_json ctx generics in - let* implied_trait_refs = - index_vec_of_json trait_clause_id_of_json trait_ref_of_json ctx - implied_trait_refs - in - let* consts = - list_of_json - (pair_of_json trait_item_name_of_json global_decl_ref_of_json) - ctx consts - in - let* types = - list_of_json - (pair_of_json trait_item_name_of_json - (binder_of_json trait_assoc_ty_impl_of_json)) - ctx types - in - let* methods = - list_of_json - (pair_of_json trait_item_name_of_json - (binder_of_json fun_decl_ref_of_json)) - ctx methods - in - let* vtable = option_of_json global_decl_ref_of_json ctx vtable in - Ok - ({ - def_id; - item_meta; - impl_trait; - generics; - implied_trait_refs; - consts; - types; - methods; - vtable; - } - : trait_impl) - | _ -> Error "") - and trait_impl_id_of_json (ctx : of_json_ctx) (js : json) : (trait_impl_id, string) result = combine_error_msgs js __FUNCTION__ @@ -2076,17 +1221,6 @@ and trait_item_name_of_json (ctx : of_json_ctx) (js : json) : | x -> string_of_json ctx x | _ -> Error "") -and trait_method_of_json (ctx : of_json_ctx) (js : json) : - (trait_method, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("name", name); ("attr_info", attr_info); ("item", item) ] -> - let* name = trait_item_name_of_json ctx name in - let* attr_info = attr_info_of_json ctx attr_info in - let* item = fun_decl_ref_of_json ctx item in - Ok ({ name; attr_info; item } : trait_method) - | _ -> Error "") - and trait_param_of_json (ctx : of_json_ctx) (js : json) : (trait_param, string) result = combine_error_msgs js __FUNCTION__ @@ -2095,13 +1229,14 @@ and trait_param_of_json (ctx : of_json_ctx) (js : json) : [ ("clause_id", clause_id); ("span", span); - ("origin", _); + ("origin", origin); ("trait_", trait); ] -> let* clause_id = trait_clause_id_of_json ctx clause_id in let* span = option_of_json span_of_json ctx span in + let* origin = predicate_origin_of_json ctx origin in let* trait = region_binder_of_json trait_decl_ref_of_json ctx trait in - Ok ({ clause_id; span; trait } : trait_param) + Ok ({ clause_id; span; origin; trait } : trait_param) | _ -> Error "") and trait_ref_of_json (ctx : of_json_ctx) (js : json) : @@ -2252,45 +1387,6 @@ and ty_kind_of_json (ctx : of_json_ctx) (js : json) : (ty_kind, string) result = Ok (TError error) | _ -> Error "") -and type_decl_of_json (ctx : of_json_ctx) (js : json) : - (type_decl, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ - ("def_id", def_id); - ("item_meta", item_meta); - ("generics", generics); - ("src", src); - ("kind", kind); - ("layout", layout); - ("ptr_metadata", ptr_metadata); - ("repr", repr); - ] -> - let* def_id = type_decl_id_of_json ctx def_id in - let* item_meta = item_meta_of_json ctx item_meta in - let* generics = generic_params_of_json ctx generics in - let* src = item_source_of_json ctx src in - let* kind = type_decl_kind_of_json ctx kind in - let* layout = - index_map_of_json string_of_json layout_of_json int_of_json ctx layout - in - let* ptr_metadata = ptr_metadata_of_json ctx ptr_metadata in - let* repr = option_of_json repr_options_of_json ctx repr in - Ok - ({ - def_id; - item_meta; - generics; - src; - kind; - layout; - ptr_metadata; - repr; - } - : type_decl) - | _ -> Error "") - and type_decl_id_of_json (ctx : of_json_ctx) (js : json) : (type_decl_id, string) result = combine_error_msgs js __FUNCTION__ @@ -2298,34 +1394,6 @@ and type_decl_id_of_json (ctx : of_json_ctx) (js : json) : | x -> TypeDeclId.id_of_json ctx x | _ -> Error "") -and type_decl_kind_of_json (ctx : of_json_ctx) (js : json) : - (type_decl_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Struct", struct_) ] -> - let* struct_ = - index_vec_of_json field_id_of_json field_of_json ctx struct_ - in - Ok (Struct struct_) - | `Assoc [ ("Enum", enum) ] -> - let* enum = - index_vec_of_json variant_id_of_json variant_of_json ctx enum - in - Ok (Enum enum) - | `Assoc [ ("Union", union) ] -> - let* union = - index_vec_of_json field_id_of_json field_of_json ctx union - in - Ok (Union union) - | `String "Opaque" -> Ok Opaque - | `Assoc [ ("Alias", alias) ] -> - let* alias = ty_of_json ctx alias in - Ok (Alias alias) - | `Assoc [ ("Error", error) ] -> - let* error = string_of_json ctx error in - Ok (TDeclError error) - | _ -> Error "") - and type_decl_ref_of_json (ctx : of_json_ctx) (js : json) : (type_decl_ref, string) result = combine_error_msgs js __FUNCTION__ @@ -2408,23 +1476,1485 @@ and unsizing_metadata_of_json (ctx : of_json_ctx) (js : json) : | `String "Unknown" -> Ok MetaUnknown | _ -> Error "") -and v_table_field_of_json (ctx : of_json_ctx) (js : json) : - (v_table_field, string) result = +and variant_id_of_json (ctx : of_json_ctx) (js : json) : + (variant_id, string) result = combine_error_msgs js __FUNCTION__ (match js with - | `String "Size" -> Ok VTableSize - | `String "Align" -> Ok VTableAlign - | `String "Drop" -> Ok VTableDrop - | `Assoc [ ("Method", method_) ] -> - let* method_ = trait_item_name_of_json ctx method_ in - Ok (VTableMethod method_) - | `Assoc [ ("SuperTrait", super_trait) ] -> - let* super_trait = trait_clause_id_of_json ctx super_trait in - Ok (VTableSuperTrait super_trait) + | x -> VariantId.id_of_json ctx x | _ -> Error "") -and variant_of_json (ctx : of_json_ctx) (js : json) : (variant, string) result = - combine_error_msgs js __FUNCTION__ +module Ullbc = struct + open UllbcAst + + let rec ___ = () + + and block_of_json (ctx : of_json_ctx) (js : json) : + (Generated_UllbcAst.block, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("statements", statements); ("terminator", terminator) ] -> + let* statements = list_of_json statement_of_json ctx statements in + let* terminator = terminator_of_json ctx terminator in + Ok ({ statements; terminator } : Generated_UllbcAst.block) + | _ -> Error "") + + and block_id_of_json (ctx : of_json_ctx) (js : json) : + (Generated_UllbcAst.block_id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | x -> BlockId.id_of_json ctx x + | _ -> Error "") + + and statement_of_json (ctx : of_json_ctx) (js : json) : + (Generated_UllbcAst.statement, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("span", span); ("kind", kind); ("comments_before", comments_before); + ] -> + let* span = span_of_json ctx span in + let* kind = statement_kind_of_json ctx kind in + let* comments_before = + list_of_json string_of_json ctx comments_before + in + Ok ({ span; kind; comments_before } : Generated_UllbcAst.statement) + | _ -> Error "") + + and statement_kind_of_json (ctx : of_json_ctx) (js : json) : + (Generated_UllbcAst.statement_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Assign", `List [ x_0; x_1 ]) ] -> + let* x_0 = place_of_json ctx x_0 in + let* x_1 = rvalue_of_json ctx x_1 in + Ok (Assign (x_0, x_1)) + | `Assoc [ ("SetDiscriminant", `List [ x_0; x_1 ]) ] -> + let* x_0 = place_of_json ctx x_0 in + let* x_1 = variant_id_of_json ctx x_1 in + Ok (SetDiscriminant (x_0, x_1)) + | `Assoc [ ("CopyNonOverlapping", copy_non_overlapping) ] -> + let* copy_non_overlapping = + box_of_json copy_non_overlapping_of_json ctx copy_non_overlapping + in + Ok (CopyNonOverlapping copy_non_overlapping) + | `Assoc [ ("StorageLive", storage_live) ] -> + let* storage_live = local_id_of_json ctx storage_live in + Ok (StorageLive storage_live) + | `Assoc [ ("StorageDead", storage_dead) ] -> + let* storage_dead = local_id_of_json ctx storage_dead in + Ok (StorageDead storage_dead) + | `Assoc [ ("PlaceMention", place_mention) ] -> + let* place_mention = place_of_json ctx place_mention in + Ok (PlaceMention place_mention) + | `Assoc + [ + ( "Assert", + `Assoc [ ("assert", assert_); ("on_failure", on_failure) ] ); + ] -> + let* assert_ = assertion_of_json ctx assert_ in + let* on_failure = abort_kind_of_json ctx on_failure in + Ok (Assert (assert_, on_failure)) + | `String "Nop" -> Ok Nop + | _ -> Error "") + + and switch_of_json (ctx : of_json_ctx) (js : json) : + (Generated_UllbcAst.switch, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("If", `List [ x_0; x_1 ]) ] -> + let* x_0 = block_id_of_json ctx x_0 in + let* x_1 = block_id_of_json ctx x_1 in + Ok (If (x_0, x_1)) + | `Assoc [ ("SwitchInt", `List [ x_0; x_1; x_2 ]) ] -> + let* x_0 = literal_type_of_json ctx x_0 in + let* x_1 = + list_of_json (pair_of_json literal_of_json block_id_of_json) ctx x_1 + in + let* x_2 = block_id_of_json ctx x_2 in + Ok (SwitchInt (x_0, x_1, x_2)) + | _ -> Error "") + + and terminator_of_json (ctx : of_json_ctx) (js : json) : + (terminator, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("span", span); ("kind", kind); ("comments_before", comments_before); + ] -> + let* span = span_of_json ctx span in + let* kind = terminator_kind_of_json ctx kind in + let* comments_before = + list_of_json string_of_json ctx comments_before + in + Ok ({ span; kind; comments_before } : terminator) + | _ -> Error "") + + and terminator_kind_of_json (ctx : of_json_ctx) (js : json) : + (terminator_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Goto", `Assoc [ ("target", target) ]) ] -> + let* target = block_id_of_json ctx target in + Ok (Goto target) + | `Assoc [ ("Switch", `Assoc [ ("discr", discr); ("targets", targets) ]) ] + -> + let* discr = operand_of_json ctx discr in + let* targets = switch_of_json ctx targets in + Ok (Switch (discr, targets)) + | `Assoc + [ + ( "Call", + `Assoc + [ ("call", call); ("target", target); ("on_unwind", on_unwind) ] + ); + ] -> + let* call = call_of_json ctx call in + let* target = block_id_of_json ctx target in + let* on_unwind = block_id_of_json ctx on_unwind in + Ok (Call (call, target, on_unwind)) + | `Assoc + [ + ( "Drop", + `Assoc + [ + ("kind", kind); + ("place", place); + ("tref", tref); + ("target", target); + ("on_unwind", on_unwind); + ] ); + ] -> + let* kind = drop_kind_of_json ctx kind in + let* place = place_of_json ctx place in + let* tref = trait_ref_of_json ctx tref in + let* target = block_id_of_json ctx target in + let* on_unwind = block_id_of_json ctx on_unwind in + Ok (Drop (kind, place, tref, target, on_unwind)) + | `Assoc + [ + ( "Assert", + `Assoc + [ + ("assert", assert_); + ("target", target); + ("on_unwind", on_unwind); + ] ); + ] -> + let* assert_ = assertion_of_json ctx assert_ in + let* target = block_id_of_json ctx target in + let* on_unwind = block_id_of_json ctx on_unwind in + Ok (TAssert (assert_, target, on_unwind)) + | `Assoc [ ("Abort", abort) ] -> + let* abort = abort_kind_of_json ctx abort in + Ok (Abort abort) + | `String "Return" -> Ok Return + | `String "UnwindResume" -> Ok UnwindResume + | _ -> Error "") +end + +module Llbc = struct + open LlbcAst + + let rec ___ = () + + and block_of_json (ctx : of_json_ctx) (js : json) : + (Generated_LlbcAst.block, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("span", span); ("statements", statements) ] -> + let* span = span_of_json ctx span in + let* statements = list_of_json statement_of_json ctx statements in + Ok ({ span; statements } : Generated_LlbcAst.block) + | _ -> Error "") + + and statement_of_json (ctx : of_json_ctx) (js : json) : + (Generated_LlbcAst.statement, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("span", span); + ("id", id); + ("kind", kind); + ("comments_before", comments_before); + ] -> + let* span = span_of_json ctx span in + let* statement_id = statement_id_of_json ctx id in + let* kind = statement_kind_of_json ctx kind in + let* comments_before = + list_of_json string_of_json ctx comments_before + in + Ok + ({ span; statement_id; kind; comments_before } + : Generated_LlbcAst.statement) + | _ -> Error "") + + and statement_id_of_json (ctx : of_json_ctx) (js : json) : + (statement_id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | x -> StatementId.id_of_json ctx x + | _ -> Error "") + + and statement_kind_of_json (ctx : of_json_ctx) (js : json) : + (Generated_LlbcAst.statement_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Assign", `List [ x_0; x_1 ]) ] -> + let* x_0 = place_of_json ctx x_0 in + let* x_1 = rvalue_of_json ctx x_1 in + Ok (Assign (x_0, x_1)) + | `Assoc [ ("SetDiscriminant", `List [ x_0; x_1 ]) ] -> + let* x_0 = place_of_json ctx x_0 in + let* x_1 = variant_id_of_json ctx x_1 in + Ok (SetDiscriminant (x_0, x_1)) + | `Assoc [ ("CopyNonOverlapping", copy_non_overlapping) ] -> + let* copy_non_overlapping = + box_of_json copy_non_overlapping_of_json ctx copy_non_overlapping + in + Ok (CopyNonOverlapping copy_non_overlapping) + | `Assoc [ ("StorageLive", storage_live) ] -> + let* storage_live = local_id_of_json ctx storage_live in + Ok (StorageLive storage_live) + | `Assoc [ ("StorageDead", storage_dead) ] -> + let* storage_dead = local_id_of_json ctx storage_dead in + Ok (StorageDead storage_dead) + | `Assoc [ ("PlaceMention", place_mention) ] -> + let* place_mention = place_of_json ctx place_mention in + Ok (PlaceMention place_mention) + | `Assoc [ ("Drop", `List [ x_0; x_1; x_2 ]) ] -> + let* x_0 = place_of_json ctx x_0 in + let* x_1 = trait_ref_of_json ctx x_1 in + let* x_2 = drop_kind_of_json ctx x_2 in + Ok (Drop (x_0, x_1, x_2)) + | `Assoc + [ + ( "Assert", + `Assoc [ ("assert", assert_); ("on_failure", on_failure) ] ); + ] -> + let* assert_ = assertion_of_json ctx assert_ in + let* on_failure = abort_kind_of_json ctx on_failure in + Ok (Assert (assert_, on_failure)) + | `Assoc [ ("Call", call) ] -> + let* call = call_of_json ctx call in + Ok (Call call) + | `Assoc [ ("Abort", abort) ] -> + let* abort = abort_kind_of_json ctx abort in + Ok (Abort abort) + | `String "Return" -> Ok Return + | `Assoc [ ("Break", break) ] -> + let* break = int_of_json ctx break in + Ok (Break break) + | `Assoc [ ("Continue", continue) ] -> + let* continue = int_of_json ctx continue in + Ok (Continue continue) + | `String "Nop" -> Ok Nop + | `Assoc [ ("Switch", switch) ] -> + let* switch = switch_of_json ctx switch in + Ok (Switch switch) + | `Assoc [ ("Loop", loop) ] -> + let* loop = block_of_json ctx loop in + Ok (Loop loop) + | `Assoc [ ("Error", error) ] -> + let* error = string_of_json ctx error in + Ok (Error error) + | _ -> Error "") + + and switch_of_json (ctx : of_json_ctx) (js : json) : + (Generated_LlbcAst.switch, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("If", `List [ x_0; x_1; x_2 ]) ] -> + let* x_0 = operand_of_json ctx x_0 in + let* x_1 = block_of_json ctx x_1 in + let* x_2 = block_of_json ctx x_2 in + Ok (If (x_0, x_1, x_2)) + | `Assoc [ ("SwitchInt", `List [ x_0; x_1; x_2; x_3 ]) ] -> + let* x_0 = operand_of_json ctx x_0 in + let* x_1 = literal_type_of_json ctx x_1 in + let* x_2 = + list_of_json + (pair_of_json (list_of_json literal_of_json) block_of_json) + ctx x_2 + in + let* x_3 = block_of_json ctx x_3 in + Ok (SwitchInt (x_0, x_1, x_2, x_3)) + | `Assoc [ ("Match", `List [ x_0; x_1; x_2 ]) ] -> + let* x_0 = place_of_json ctx x_0 in + let* x_1 = + list_of_json + (pair_of_json (list_of_json variant_id_of_json) block_of_json) + ctx x_1 + in + let* x_2 = option_of_json block_of_json ctx x_2 in + Ok (Match (x_0, x_1, x_2)) + | _ -> Error "") +end + +let rec ___ = () + +and alignment_modifier_of_json (ctx : of_json_ctx) (js : json) : + (alignment_modifier, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Align", align) ] -> + let* align = int_of_json ctx align in + Ok (Align align) + | `Assoc [ ("Pack", pack) ] -> + let* pack = int_of_json ctx pack in + Ok (Pack pack) + | _ -> Error "") + +and attr_info_of_json (ctx : of_json_ctx) (js : json) : + (attr_info, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("attributes", attributes); + ("inline", inline); + ("rename", rename); + ("public", public); + ] -> + let* attributes = list_of_json attribute_of_json ctx attributes in + let* inline = option_of_json inline_attr_of_json ctx inline in + let* rename = option_of_json string_of_json ctx rename in + let* public = bool_of_json ctx public in + Ok ({ attributes; inline; rename; public } : attr_info) + | _ -> Error "") + +and attribute_of_json (ctx : of_json_ctx) (js : json) : + (attribute, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Opaque" -> Ok AttrOpaque + | `String "Exclude" -> Ok AttrExclude + | `Assoc [ ("Rename", rename) ] -> + let* rename = string_of_json ctx rename in + Ok (AttrRename rename) + | `Assoc [ ("VariantsPrefix", variants_prefix) ] -> + let* variants_prefix = string_of_json ctx variants_prefix in + Ok (AttrVariantsPrefix variants_prefix) + | `Assoc [ ("VariantsSuffix", variants_suffix) ] -> + let* variants_suffix = string_of_json ctx variants_suffix in + Ok (AttrVariantsSuffix variants_suffix) + | `Assoc [ ("DocComment", doc_comment) ] -> + let* doc_comment = string_of_json ctx doc_comment in + Ok (AttrDocComment doc_comment) + | `Assoc [ ("Unknown", unknown) ] -> + let* unknown = raw_attribute_of_json ctx unknown in + Ok (AttrUnknown unknown) + | _ -> Error "") + +and body_of_json (ctx : of_json_ctx) (js : json) : (body, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Unstructured", unstructured) ] -> + let* unstructured = + gexpr_body_of_json + (index_vec_of_json Ullbc.block_id_of_json Ullbc.block_of_json) + ctx unstructured + in + Ok (UnstructuredBody unstructured) + | `Assoc [ ("Structured", structured) ] -> + let* structured = + gexpr_body_of_json Llbc.block_of_json ctx structured + in + Ok (StructuredBody structured) + | `Assoc [ ("TargetDispatch", target_dispatch) ] -> + let* target_dispatch = + index_map_of_json string_of_json fun_decl_ref_of_json int_of_json ctx + target_dispatch + in + Ok (TargetDispatchBody target_dispatch) + | `String "TraitMethodWithoutDefault" -> Ok TraitMethodWithoutDefaultBody + | `Assoc [ ("Extern", extern) ] -> + let* extern = string_of_json ctx extern in + Ok (ExternBody extern) + | `Assoc + [ ("Intrinsic", `Assoc [ ("name", name); ("arg_names", arg_names) ]) ] + -> + let* name = string_of_json ctx name in + let* arg_names = + list_of_json (option_of_json string_of_json) ctx arg_names + in + Ok (IntrinsicBody (name, arg_names)) + | `String "Opaque" -> Ok OpaqueBody + | `String "Missing" -> Ok MissingBody + | `Assoc [ ("Error", error) ] -> + let* error = error_of_json ctx error in + Ok (ErrorBody error) + | _ -> Error "") + +and cli_options_of_json (ctx : of_json_ctx) (js : json) : + (cli_options, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("ullbc", ullbc); + ("precise_drops", precise_drops); + ("skip_borrowck", skip_borrowck); + ("mir", mir); + ("rustc_args", rustc_args); + ("targets", targets); + ("monomorphize", monomorphize); + ("monomorphize_mut", monomorphize_mut); + ("start_from", start_from); + ("start_from_if_exists", start_from_if_exists); + ("start_from_attribute", start_from_attribute); + ("start_from_pub", start_from_pub); + ("include", include_); + ("opaque", opaque); + ("exclude", exclude); + ("extract_opaque_bodies", extract_opaque_bodies); + ("translate_all_methods", translate_all_methods); + ("lift_associated_types", lift_associated_types); + ("hide_marker_traits", hide_marker_traits); + ("remove_adt_clauses", remove_adt_clauses); + ("hide_allocator", hide_allocator); + ("remove_unused_self_clauses", remove_unused_self_clauses); + ("desugar_drops", desugar_drops); + ("ops_to_function_calls", ops_to_function_calls); + ("index_to_function_calls", index_to_function_calls); + ("treat_box_as_builtin", treat_box_as_builtin); + ("raw_consts", raw_consts); + ("unsized_strings", unsized_strings); + ("reconstruct_fallible_operations", reconstruct_fallible_operations); + ("reconstruct_asserts", reconstruct_asserts); + ("unbind_item_vars", unbind_item_vars); + ("print_original_ullbc", print_original_ullbc); + ("print_ullbc", print_ullbc); + ("print_built_llbc", print_built_llbc); + ("print_llbc", print_llbc); + ("dest_dir", dest_dir); + ("dest_file", dest_file); + ("no_dedup_serialized_ast", no_dedup_serialized_ast); + ("no_serialize", no_serialize); + ("no_typecheck", no_typecheck); + ("no_normalize", no_normalize); + ("abort_on_error", abort_on_error); + ("error_on_warnings", error_on_warnings); + ("preset", preset); + ] -> + let* ullbc = bool_of_json ctx ullbc in + let* precise_drops = bool_of_json ctx precise_drops in + let* skip_borrowck = bool_of_json ctx skip_borrowck in + let* mir = option_of_json mir_level_of_json ctx mir in + let* rustc_args = list_of_json string_of_json ctx rustc_args in + let* targets = list_of_json string_of_json ctx targets in + let* monomorphize = bool_of_json ctx monomorphize in + let* monomorphize_mut = + option_of_json monomorphize_mut_of_json ctx monomorphize_mut + in + let* start_from = list_of_json string_of_json ctx start_from in + let* start_from_if_exists = + list_of_json string_of_json ctx start_from_if_exists + in + let* start_from_attribute = + option_of_json string_of_json ctx start_from_attribute + in + let* start_from_pub = bool_of_json ctx start_from_pub in + let* included = list_of_json string_of_json ctx include_ in + let* opaque = list_of_json string_of_json ctx opaque in + let* exclude = list_of_json string_of_json ctx exclude in + let* extract_opaque_bodies = bool_of_json ctx extract_opaque_bodies in + let* translate_all_methods = bool_of_json ctx translate_all_methods in + let* lift_associated_types = + list_of_json string_of_json ctx lift_associated_types + in + let* hide_marker_traits = bool_of_json ctx hide_marker_traits in + let* remove_adt_clauses = bool_of_json ctx remove_adt_clauses in + let* hide_allocator = bool_of_json ctx hide_allocator in + let* remove_unused_self_clauses = + bool_of_json ctx remove_unused_self_clauses + in + let* desugar_drops = bool_of_json ctx desugar_drops in + let* ops_to_function_calls = bool_of_json ctx ops_to_function_calls in + let* index_to_function_calls = + bool_of_json ctx index_to_function_calls + in + let* treat_box_as_builtin = bool_of_json ctx treat_box_as_builtin in + let* raw_consts = bool_of_json ctx raw_consts in + let* unsized_strings = bool_of_json ctx unsized_strings in + let* reconstruct_fallible_operations = + bool_of_json ctx reconstruct_fallible_operations + in + let* reconstruct_asserts = bool_of_json ctx reconstruct_asserts in + let* unbind_item_vars = bool_of_json ctx unbind_item_vars in + let* print_original_ullbc = bool_of_json ctx print_original_ullbc in + let* print_ullbc = bool_of_json ctx print_ullbc in + let* print_built_llbc = bool_of_json ctx print_built_llbc in + let* print_llbc = bool_of_json ctx print_llbc in + let* dest_dir = option_of_json path_buf_of_json ctx dest_dir in + let* dest_file = option_of_json path_buf_of_json ctx dest_file in + let* no_dedup_serialized_ast = + bool_of_json ctx no_dedup_serialized_ast + in + let* no_serialize = bool_of_json ctx no_serialize in + let* no_typecheck = bool_of_json ctx no_typecheck in + let* no_normalize = bool_of_json ctx no_normalize in + let* abort_on_error = bool_of_json ctx abort_on_error in + let* error_on_warnings = bool_of_json ctx error_on_warnings in + let* preset = option_of_json preset_of_json ctx preset in + Ok + ({ + ullbc; + precise_drops; + skip_borrowck; + mir; + rustc_args; + targets; + monomorphize; + monomorphize_mut; + start_from; + start_from_if_exists; + start_from_attribute; + start_from_pub; + included; + opaque; + exclude; + extract_opaque_bodies; + translate_all_methods; + lift_associated_types; + hide_marker_traits; + remove_adt_clauses; + hide_allocator; + remove_unused_self_clauses; + desugar_drops; + ops_to_function_calls; + index_to_function_calls; + treat_box_as_builtin; + raw_consts; + unsized_strings; + reconstruct_fallible_operations; + reconstruct_asserts; + unbind_item_vars; + print_original_ullbc; + print_ullbc; + print_built_llbc; + print_llbc; + dest_dir; + dest_file; + no_dedup_serialized_ast; + no_serialize; + no_typecheck; + no_normalize; + abort_on_error; + error_on_warnings; + preset; + } + : cli_options) + | _ -> Error "") + +and closure_info_of_json (ctx : of_json_ctx) (js : json) : + (closure_info, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("kind", kind); + ("fn_once_impl", fn_once_impl); + ("fn_mut_impl", fn_mut_impl); + ("fn_impl", fn_impl); + ("signature", signature); + ] -> + let* kind = closure_kind_of_json ctx kind in + let* fn_once_impl = + region_binder_of_json trait_impl_ref_of_json ctx fn_once_impl + in + let* fn_mut_impl = + option_of_json + (region_binder_of_json trait_impl_ref_of_json) + ctx fn_mut_impl + in + let* fn_impl = + option_of_json + (region_binder_of_json trait_impl_ref_of_json) + ctx fn_impl + in + let* signature = region_binder_of_json fun_sig_of_json ctx signature in + Ok + ({ kind; fn_once_impl; fn_mut_impl; fn_impl; signature } + : closure_info) + | _ -> Error "") + +and closure_kind_of_json (ctx : of_json_ctx) (js : json) : + (closure_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Fn" -> Ok Fn + | `String "FnMut" -> Ok FnMut + | `String "FnOnce" -> Ok FnOnce + | _ -> Error "") + +and declaration_group_of_json (ctx : of_json_ctx) (js : json) : + (declaration_group, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Type", type_) ] -> + let* type_ = + g_declaration_group_of_json type_decl_id_of_json ctx type_ + in + Ok (TypeGroup type_) + | `Assoc [ ("Fun", fun_) ] -> + let* fun_ = g_declaration_group_of_json fun_decl_id_of_json ctx fun_ in + Ok (FunGroup fun_) + | `Assoc [ ("Global", global) ] -> + let* global = + g_declaration_group_of_json global_decl_id_of_json ctx global + in + Ok (GlobalGroup global) + | `Assoc [ ("TraitDecl", trait_decl) ] -> + let* trait_decl = + g_declaration_group_of_json trait_decl_id_of_json ctx trait_decl + in + Ok (TraitDeclGroup trait_decl) + | `Assoc [ ("TraitImpl", trait_impl) ] -> + let* trait_impl = + g_declaration_group_of_json trait_impl_id_of_json ctx trait_impl + in + Ok (TraitImplGroup trait_impl) + | `Assoc [ ("Mixed", mixed) ] -> + let* mixed = g_declaration_group_of_json item_id_of_json ctx mixed in + Ok (MixedGroup mixed) + | _ -> Error "") + +and discriminant_layout_of_json (ctx : of_json_ctx) (js : json) : + (discriminant_layout, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("offset", offset); ("tag_ty", tag_ty); ("encoding", encoding) ] + -> + let* offset = int_of_json ctx offset in + let* tag_ty = integer_type_of_json ctx tag_ty in + let* encoding = tag_encoding_of_json ctx encoding in + Ok ({ offset; tag_ty; encoding } : discriminant_layout) + | _ -> Error "") + +and error_of_json (ctx : of_json_ctx) (js : json) : (error, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("span", span); ("msg", msg) ] -> + let* span = span_of_json ctx span in + let* msg = string_of_json ctx msg in + Ok ({ span; msg } : error) + | _ -> Error "") + +and field_of_json (ctx : of_json_ctx) (js : json) : (field, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ ("span", span); ("attr_info", attr_info); ("name", name); ("ty", ty) ] + -> + let* span = span_of_json ctx span in + let* attr_info = attr_info_of_json ctx attr_info in + let* field_name = option_of_json string_of_json ctx name in + let* field_ty = ty_of_json ctx ty in + Ok ({ span; attr_info; field_name; field_ty } : field) + | _ -> Error "") + +and file_of_json (ctx : of_json_ctx) (js : json) : (file, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | json -> ( + match json with + | `Assoc + [ + ("id", id); + ("name", name); + ("crate_name", crate_name); + ("contents", contents); + ] -> + let* id = FileId.id_of_json ctx id in + let* name = file_name_of_json ctx name in + let* crate_name = string_of_json ctx crate_name in + let* contents = option_of_json string_of_json ctx contents in + let file : file = { name; crate_name; contents } in + FileTbl.add ctx.id_to_file_map id file; + Ok file + | _ -> Error "") + | _ -> Error "") + +and file_name_of_json (ctx : of_json_ctx) (js : json) : + (file_name, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Virtual", virtual_) ] -> + let* virtual_ = path_buf_of_json ctx virtual_ in + Ok (Virtual virtual_) + | `Assoc [ ("Local", local) ] -> + let* local = path_buf_of_json ctx local in + Ok (Local local) + | `Assoc [ ("NotReal", not_real) ] -> + let* not_real = string_of_json ctx not_real in + Ok (NotReal not_real) + | _ -> Error "") + +and fun_decl_of_json (ctx : of_json_ctx) (js : json) : (fun_decl, string) result + = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("item_meta", item_meta); + ("generics", generics); + ("signature", signature); + ("src", src); + ("is_global_initializer", is_global_initializer); + ("body", body); + ] -> + let* def_id = fun_decl_id_of_json ctx def_id in + let* item_meta = item_meta_of_json ctx item_meta in + let* generics = generic_params_of_json ctx generics in + let* signature = fun_sig_of_json ctx signature in + let* src = item_source_of_json ctx src in + let* is_global_initializer = + option_of_json global_decl_id_of_json ctx is_global_initializer + in + let* body = body_of_json ctx body in + Ok + ({ + def_id; + item_meta; + generics; + signature; + src; + is_global_initializer; + body; + } + : fun_decl) + | _ -> Error "") + +and g_declaration_group_of_json : + 'a0. + (of_json_ctx -> json -> ('a0, string) result) -> + of_json_ctx -> + json -> + ('a0 g_declaration_group, string) result = + fun arg0_of_json ctx js -> + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("NonRec", non_rec) ] -> + let* non_rec = arg0_of_json ctx non_rec in + Ok (NonRecGroup non_rec) + | `Assoc [ ("Rec", rec_) ] -> + let* rec_ = list_of_json arg0_of_json ctx rec_ in + Ok (RecGroup rec_) + | _ -> Error "") + +and gexpr_body_of_json : + 'a0. + (of_json_ctx -> json -> ('a0, string) result) -> + of_json_ctx -> + json -> + ('a0 gexpr_body, string) result = + fun arg0_of_json ctx js -> + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("span", span); + ("bound_body_regions", bound_body_regions); + ("locals", locals); + ("body", body); + ("comments", _); + ] -> + let* span = span_of_json ctx span in + let* bound_body_regions = int_of_json ctx bound_body_regions in + let* locals = locals_of_json ctx locals in + let* body = arg0_of_json ctx body in + Ok ({ span; bound_body_regions; locals; body } : _ gexpr_body) + | _ -> Error "") + +and global_decl_of_json (ctx : of_json_ctx) (js : json) : + (global_decl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("item_meta", item_meta); + ("generics", generics); + ("ty", ty); + ("src", src); + ("global_kind", global_kind); + ("init", init); + ] -> + let* def_id = global_decl_id_of_json ctx def_id in + let* item_meta = item_meta_of_json ctx item_meta in + let* generics = generic_params_of_json ctx generics in + let* ty = ty_of_json ctx ty in + let* src = item_source_of_json ctx src in + let* global_kind = global_kind_of_json ctx global_kind in + let* init = fun_decl_id_of_json ctx init in + Ok + ({ def_id; item_meta; generics; ty; src; global_kind; init } + : global_decl) + | _ -> Error "") + +and global_kind_of_json (ctx : of_json_ctx) (js : json) : + (global_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Static" -> Ok Static + | `String "NamedConst" -> Ok NamedConst + | `String "AnonConst" -> Ok AnonConst + | _ -> Error "") + +and index_map_of_json : + 'a0 'a1 'a2. + (of_json_ctx -> json -> ('a0, string) result) -> + (of_json_ctx -> json -> ('a1, string) result) -> + (of_json_ctx -> json -> ('a2, string) result) -> + of_json_ctx -> + json -> + (('a0 * 'a1) list, string) result = + fun arg0_of_json arg1_of_json arg2_of_json ctx js -> + combine_error_msgs js __FUNCTION__ + (match js with + | json -> + list_of_json (key_value_pair_of_json arg0_of_json arg1_of_json) ctx json + | _ -> Error "") + +and indexed_map_of_json : + 'a0 'a1. + (of_json_ctx -> json -> ('a0, string) result) -> + (of_json_ctx -> json -> ('a1, string) result) -> + of_json_ctx -> + json -> + ('a1 list, string) result = + fun arg0_of_json arg1_of_json ctx js -> + combine_error_msgs js __FUNCTION__ + (match js with + | json -> + let* list = list_of_json (option_of_json arg1_of_json) ctx json in + Ok (List.filter_map (fun x -> x) list) + | _ -> Error "") + +and inline_attr_of_json (ctx : of_json_ctx) (js : json) : + (inline_attr, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Hint" -> Ok Hint + | `String "Never" -> Ok Never + | `String "Always" -> Ok Always + | _ -> Error "") + +and integer_type_of_json (ctx : of_json_ctx) (js : json) : + (integer_type, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Signed", signed) ] -> + let* signed = int_ty_of_json ctx signed in + Ok (Signed signed) + | `Assoc [ ("Unsigned", unsigned) ] -> + let* unsigned = u_int_ty_of_json ctx unsigned in + Ok (Unsigned unsigned) + | _ -> Error "") + +and item_id_of_json (ctx : of_json_ctx) (js : json) : (item_id, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Type", type_) ] -> + let* type_ = type_decl_id_of_json ctx type_ in + Ok (IdType type_) + | `Assoc [ ("TraitDecl", trait_decl) ] -> + let* trait_decl = trait_decl_id_of_json ctx trait_decl in + Ok (IdTraitDecl trait_decl) + | `Assoc [ ("TraitImpl", trait_impl) ] -> + let* trait_impl = trait_impl_id_of_json ctx trait_impl in + Ok (IdTraitImpl trait_impl) + | `Assoc [ ("Fun", fun_) ] -> + let* fun_ = fun_decl_id_of_json ctx fun_ in + Ok (IdFun fun_) + | `Assoc [ ("Global", global) ] -> + let* global = global_decl_id_of_json ctx global in + Ok (IdGlobal global) + | _ -> Error "") + +and item_meta_of_json (ctx : of_json_ctx) (js : json) : + (item_meta, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("name", name); + ("span", span); + ("source_text", source_text); + ("attr_info", attr_info); + ("is_local", is_local); + ("opacity", opacity); + ("lang_item", lang_item); + ] -> + let* name = name_of_json ctx name in + let* span = span_of_json ctx span in + let* source_text = option_of_json string_of_json ctx source_text in + let* attr_info = attr_info_of_json ctx attr_info in + let* is_local = bool_of_json ctx is_local in + let* opacity = item_opacity_of_json ctx opacity in + let* lang_item = option_of_json string_of_json ctx lang_item in + Ok + ({ name; span; source_text; attr_info; is_local; opacity; lang_item } + : item_meta) + | _ -> Error "") + +and item_opacity_of_json (ctx : of_json_ctx) (js : json) : + (item_opacity, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Transparent" -> Ok Transparent + | `String "Foreign" -> Ok Foreign + | `String "Opaque" -> Ok ItemOpaque + | `String "Invisible" -> Ok Invisible + | _ -> Error "") + +and item_source_of_json (ctx : of_json_ctx) (js : json) : + (item_source, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "TopLevel" -> Ok TopLevelItem + | `Assoc [ ("Closure", `Assoc [ ("info", info) ]) ] -> + let* info = closure_info_of_json ctx info in + Ok (ClosureItem info) + | `Assoc + [ + ( "TraitDecl", + `Assoc + [ + ("trait_ref", trait_ref); + ("item_name", item_name); + ("has_default", has_default); + ] ); + ] -> + let* trait_ref = trait_decl_ref_of_json ctx trait_ref in + let* item_name = trait_item_name_of_json ctx item_name in + let* has_default = bool_of_json ctx has_default in + Ok (TraitDeclItem (trait_ref, item_name, has_default)) + | `Assoc + [ + ( "TraitImpl", + `Assoc + [ + ("impl_ref", impl_ref); + ("trait_ref", trait_ref); + ("item_name", item_name); + ("reuses_default", reuses_default); + ] ); + ] -> + let* impl_ref = trait_impl_ref_of_json ctx impl_ref in + let* trait_ref = trait_decl_ref_of_json ctx trait_ref in + let* item_name = trait_item_name_of_json ctx item_name in + let* reuses_default = bool_of_json ctx reuses_default in + Ok (TraitImplItem (impl_ref, trait_ref, item_name, reuses_default)) + | `Assoc + [ + ( "VTableTy", + `Assoc + [ + ("dyn_predicate", dyn_predicate); + ("field_map", field_map); + ("supertrait_map", supertrait_map); + ] ); + ] -> + let* dyn_predicate = dyn_predicate_of_json ctx dyn_predicate in + let* field_map = + index_vec_of_json field_id_of_json v_table_field_of_json ctx field_map + in + let* supertrait_map = + index_vec_of_json trait_clause_id_of_json + (option_of_json field_id_of_json) + ctx supertrait_map + in + Ok (VTableTyItem (dyn_predicate, field_map, supertrait_map)) + | `Assoc [ ("VTableInstance", `Assoc [ ("impl_ref", impl_ref) ]) ] -> + let* impl_ref = trait_impl_ref_of_json ctx impl_ref in + Ok (VTableInstanceItem impl_ref) + | `String "VTableMethodShim" -> Ok VTableMethodShimItem + | `String "VTableInstanceMono" -> Ok VTableInstanceMonoItem + | `Assoc [ ("VTableMethodPreShim", `List [ x_0; x_1; x_2 ]) ] -> + let* x_0 = trait_decl_id_of_json ctx x_0 in + let* x_1 = trait_item_name_of_json ctx x_1 in + let* x_2 = list_of_json ty_of_json ctx x_2 in + Ok (VTableMethodPreShimItem (x_0, x_1, x_2)) + | _ -> Error "") + +and layout_of_json (ctx : of_json_ctx) (js : json) : (layout, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("size", size); + ("align", align); + ("discriminant_layout", discriminant_layout); + ("uninhabited", uninhabited); + ("variant_layouts", variant_layouts); + ] -> + let* size = option_of_json int_of_json ctx size in + let* align = option_of_json int_of_json ctx align in + let* discriminant_layout = + option_of_json discriminant_layout_of_json ctx discriminant_layout + in + let* uninhabited = bool_of_json ctx uninhabited in + let* variant_layouts = + index_vec_of_json variant_id_of_json variant_layout_of_json ctx + variant_layouts + in + Ok + ({ size; align; discriminant_layout; uninhabited; variant_layouts } + : layout) + | _ -> Error "") + +and local_of_json (ctx : of_json_ctx) (js : json) : (local, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("index", index); ("name", name); ("span", span); ("ty", ty) ] -> + let* index = local_id_of_json ctx index in + let* name = option_of_json string_of_json ctx name in + let* span = span_of_json ctx span in + let* local_ty = ty_of_json ctx ty in + Ok ({ index; name; span; local_ty } : local) + | _ -> Error "") + +and locals_of_json (ctx : of_json_ctx) (js : json) : (locals, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("arg_count", arg_count); ("locals", locals) ] -> + let* arg_count = int_of_json ctx arg_count in + let* locals = + index_vec_of_json local_id_of_json local_of_json ctx locals + in + Ok ({ arg_count; locals } : locals) + | _ -> Error "") + +and mir_level_of_json (ctx : of_json_ctx) (js : json) : + (mir_level, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Built" -> Ok Built + | `String "Promoted" -> Ok Promoted + | `String "Elaborated" -> Ok Elaborated + | `String "Optimized" -> Ok Optimized + | _ -> Error "") + +and monomorphize_mut_of_json (ctx : of_json_ctx) (js : json) : + (monomorphize_mut, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "All" -> Ok All + | `String "ExceptTypes" -> Ok ExceptTypes + | _ -> Error "") + +and preset_of_json (ctx : of_json_ctx) (js : json) : (preset, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "OldDefaults" -> Ok OldDefaults + | `String "RawMir" -> Ok RawMir + | `String "Fast" -> Ok Fast + | `String "Aeneas" -> Ok Aeneas + | `String "Eurydice" -> Ok Eurydice + | `String "Soteria" -> Ok Soteria + | `String "Tests" -> Ok Tests + | _ -> Error "") + +and ptr_metadata_of_json (ctx : of_json_ctx) (js : json) : + (ptr_metadata, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "None" -> Ok NoMetadata + | `String "Length" -> Ok Length + | `Assoc [ ("VTable", v_table) ] -> + let* v_table = type_decl_ref_of_json ctx v_table in + Ok (VTable v_table) + | `Assoc [ ("InheritFrom", inherit_from) ] -> + let* inherit_from = ty_of_json ctx inherit_from in + Ok (InheritFrom inherit_from) + | _ -> Error "") + +and raw_attribute_of_json (ctx : of_json_ctx) (js : json) : + (raw_attribute, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("path", path); ("args", args) ] -> + let* path = string_of_json ctx path in + let* args = option_of_json string_of_json ctx args in + Ok ({ path; args } : raw_attribute) + | _ -> Error "") + +and repr_algorithm_of_json (ctx : of_json_ctx) (js : json) : + (repr_algorithm, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Rust" -> Ok Rust + | `String "C" -> Ok C + | _ -> Error "") + +and repr_options_of_json (ctx : of_json_ctx) (js : json) : + (repr_options, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("repr_algo", repr_algo); + ("align_modif", align_modif); + ("transparent", transparent); + ("explicit_discr_type", explicit_discr_type); + ] -> + let* repr_algo = repr_algorithm_of_json ctx repr_algo in + let* align_modif = + option_of_json alignment_modifier_of_json ctx align_modif + in + let* transparent = bool_of_json ctx transparent in + let* explicit_discr_type = bool_of_json ctx explicit_discr_type in + Ok + ({ repr_algo; align_modif; transparent; explicit_discr_type } + : repr_options) + | _ -> Error "") + +and tag_encoding_of_json (ctx : of_json_ctx) (js : json) : + (tag_encoding, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Direct" -> Ok Direct + | `Assoc [ ("Niche", `Assoc [ ("untagged_variant", untagged_variant) ]) ] -> + let* untagged_variant = variant_id_of_json ctx untagged_variant in + Ok (Niche untagged_variant) + | _ -> Error "") + +and target_info_of_json (ctx : of_json_ctx) (js : json) : + (target_info, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("target_pointer_size", target_pointer_size); + ("is_little_endian", is_little_endian); + ] -> + let* target_pointer_size = int_of_json ctx target_pointer_size in + let* is_little_endian = bool_of_json ctx is_little_endian in + Ok ({ target_pointer_size; is_little_endian } : target_info) + | _ -> Error "") + +and trait_assoc_const_of_json (ctx : of_json_ctx) (js : json) : + (trait_assoc_const, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("name", name); + ("attr_info", attr_info); + ("ty", ty); + ("default", default); + ] -> + let* name = trait_item_name_of_json ctx name in + let* attr_info = attr_info_of_json ctx attr_info in + let* ty = ty_of_json ctx ty in + let* default = option_of_json global_decl_ref_of_json ctx default in + Ok ({ name; attr_info; ty; default } : trait_assoc_const) + | _ -> Error "") + +and trait_assoc_ty_of_json (ctx : of_json_ctx) (js : json) : + (trait_assoc_ty, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("name", name); + ("attr_info", attr_info); + ("default", default); + ("implied_clauses", implied_clauses); + ] -> + let* name = trait_item_name_of_json ctx name in + let* attr_info = attr_info_of_json ctx attr_info in + let* default = option_of_json trait_assoc_ty_impl_of_json ctx default in + let* implied_clauses = + index_vec_of_json trait_clause_id_of_json trait_param_of_json ctx + implied_clauses + in + Ok ({ name; attr_info; default; implied_clauses } : trait_assoc_ty) + | _ -> Error "") + +and trait_decl_of_json (ctx : of_json_ctx) (js : json) : + (trait_decl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("item_meta", item_meta); + ("generics", generics); + ("implied_clauses", implied_clauses); + ("consts", consts); + ("types", types); + ("methods", methods); + ("vtable", vtable); + ] -> + let* def_id = trait_decl_id_of_json ctx def_id in + let* item_meta = item_meta_of_json ctx item_meta in + let* generics = generic_params_of_json ctx generics in + let* implied_clauses = + index_vec_of_json trait_clause_id_of_json trait_param_of_json ctx + implied_clauses + in + let* consts = list_of_json trait_assoc_const_of_json ctx consts in + let* types = + list_of_json (binder_of_json trait_assoc_ty_of_json) ctx types + in + let* methods = + list_of_json (binder_of_json trait_method_of_json) ctx methods + in + let* vtable = option_of_json type_decl_ref_of_json ctx vtable in + Ok + ({ + def_id; + item_meta; + generics; + implied_clauses; + consts; + types; + methods; + vtable; + } + : trait_decl) + | _ -> Error "") + +and trait_impl_of_json (ctx : of_json_ctx) (js : json) : + (trait_impl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("item_meta", item_meta); + ("impl_trait", impl_trait); + ("generics", generics); + ("implied_trait_refs", implied_trait_refs); + ("consts", consts); + ("types", types); + ("methods", methods); + ("vtable", vtable); + ] -> + let* def_id = trait_impl_id_of_json ctx def_id in + let* item_meta = item_meta_of_json ctx item_meta in + let* impl_trait = trait_decl_ref_of_json ctx impl_trait in + let* generics = generic_params_of_json ctx generics in + let* implied_trait_refs = + index_vec_of_json trait_clause_id_of_json trait_ref_of_json ctx + implied_trait_refs + in + let* consts = + list_of_json + (pair_of_json trait_item_name_of_json global_decl_ref_of_json) + ctx consts + in + let* types = + list_of_json + (pair_of_json trait_item_name_of_json + (binder_of_json trait_assoc_ty_impl_of_json)) + ctx types + in + let* methods = + list_of_json + (pair_of_json trait_item_name_of_json + (binder_of_json fun_decl_ref_of_json)) + ctx methods + in + let* vtable = option_of_json global_decl_ref_of_json ctx vtable in + Ok + ({ + def_id; + item_meta; + impl_trait; + generics; + implied_trait_refs; + consts; + types; + methods; + vtable; + } + : trait_impl) + | _ -> Error "") + +and trait_method_of_json (ctx : of_json_ctx) (js : json) : + (trait_method, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("name", name); ("attr_info", attr_info); ("item", item) ] -> + let* name = trait_item_name_of_json ctx name in + let* attr_info = attr_info_of_json ctx attr_info in + let* item = fun_decl_ref_of_json ctx item in + Ok ({ name; attr_info; item } : trait_method) + | _ -> Error "") + +and translated_crate_of_json (ctx : of_json_ctx) (js : json) : + (translated_crate, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("crate_name", crate_name); + ("options", options); + ("target_information", target_information); + ("files", files); + ("item_names", item_names); + ("short_names", short_names); + ("type_decls", type_decls); + ("fun_decls", fun_decls); + ("global_decls", global_decls); + ("trait_decls", trait_decls); + ("trait_impls", trait_impls); + ("unit_metadata", unit_metadata); + ("ordered_decls", ordered_decls); + ] -> + let* crate_name = string_of_json ctx crate_name in + let* options = cli_options_of_json ctx options in + let* target_information = + index_map_of_json string_of_json target_info_of_json int_of_json ctx + target_information + in + let* files = index_vec_of_json file_id_of_json file_of_json ctx files in + let* item_names = + index_map_of_json item_id_of_json name_of_json int_of_json ctx + item_names + in + let* short_names = + index_map_of_json item_id_of_json name_of_json int_of_json ctx + short_names + in + let* type_decls = + opt_indexed_map_of_json type_decl_id_of_json type_decl_of_json ctx + type_decls + in + let* fun_decls = + opt_indexed_map_of_json fun_decl_id_of_json fun_decl_of_json ctx + fun_decls + in + let* global_decls = + opt_indexed_map_of_json global_decl_id_of_json global_decl_of_json ctx + global_decls + in + let* trait_decls = + opt_indexed_map_of_json trait_decl_id_of_json trait_decl_of_json ctx + trait_decls + in + let* trait_impls = + opt_indexed_map_of_json trait_impl_id_of_json trait_impl_of_json ctx + trait_impls + in + let* unit_metadata = + option_of_json global_decl_ref_of_json ctx unit_metadata + in + let* ordered_decls = + option_of_json + (list_of_json declaration_group_of_json) + ctx ordered_decls + in + Ok + ({ + crate_name; + options; + target_information; + files; + item_names; + short_names; + type_decls; + fun_decls; + global_decls; + trait_decls; + trait_impls; + unit_metadata; + ordered_decls; + } + : translated_crate) + | _ -> Error "") + +and type_decl_of_json (ctx : of_json_ctx) (js : json) : + (type_decl, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc + [ + ("def_id", def_id); + ("item_meta", item_meta); + ("generics", generics); + ("src", src); + ("kind", kind); + ("layout", layout); + ("ptr_metadata", ptr_metadata); + ("repr", repr); + ] -> + let* def_id = type_decl_id_of_json ctx def_id in + let* item_meta = item_meta_of_json ctx item_meta in + let* generics = generic_params_of_json ctx generics in + let* src = item_source_of_json ctx src in + let* kind = type_decl_kind_of_json ctx kind in + let* layout = + index_map_of_json string_of_json layout_of_json int_of_json ctx layout + in + let* ptr_metadata = ptr_metadata_of_json ctx ptr_metadata in + let* repr = option_of_json repr_options_of_json ctx repr in + Ok + ({ + def_id; + item_meta; + generics; + src; + kind; + layout; + ptr_metadata; + repr; + } + : type_decl) + | _ -> Error "") + +and type_decl_kind_of_json (ctx : of_json_ctx) (js : json) : + (type_decl_kind, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `Assoc [ ("Struct", struct_) ] -> + let* struct_ = + index_vec_of_json field_id_of_json field_of_json ctx struct_ + in + Ok (Struct struct_) + | `Assoc [ ("Enum", enum) ] -> + let* enum = + index_vec_of_json variant_id_of_json variant_of_json ctx enum + in + Ok (Enum enum) + | `Assoc [ ("Union", union) ] -> + let* union = + index_vec_of_json field_id_of_json field_of_json ctx union + in + Ok (Union union) + | `String "Opaque" -> Ok Opaque + | `Assoc [ ("Alias", alias) ] -> + let* alias = ty_of_json ctx alias in + Ok (Alias alias) + | `Assoc [ ("Error", error) ] -> + let* error = string_of_json ctx error in + Ok (TDeclError error) + | _ -> Error "") + +and v_table_field_of_json (ctx : of_json_ctx) (js : json) : + (v_table_field, string) result = + combine_error_msgs js __FUNCTION__ + (match js with + | `String "Size" -> Ok VTableSize + | `String "Align" -> Ok VTableAlign + | `String "Drop" -> Ok VTableDrop + | `Assoc [ ("Method", method_) ] -> + let* method_ = trait_item_name_of_json ctx method_ in + Ok (VTableMethod method_) + | `Assoc [ ("SuperTrait", super_trait) ] -> + let* super_trait = trait_clause_id_of_json ctx super_trait in + Ok (VTableSuperTrait super_trait) + | _ -> Error "") + +and variant_of_json (ctx : of_json_ctx) (js : json) : (variant, string) result = + combine_error_msgs js __FUNCTION__ (match js with | `Assoc [ @@ -2444,13 +2974,6 @@ and variant_of_json (ctx : of_json_ctx) (js : json) : (variant, string) result = Ok ({ span; attr_info; variant_name; fields; discriminant } : variant) | _ -> Error "") -and variant_id_of_json (ctx : of_json_ctx) (js : json) : - (variant_id, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | x -> VariantId.id_of_json ctx x - | _ -> Error "") - and variant_layout_of_json (ctx : of_json_ctx) (js : json) : (variant_layout, string) result = combine_error_msgs js __FUNCTION__ diff --git a/charon-ml/src/generated/Generated_Types.ml b/charon-ml/src/generated/Generated_Types.ml index ee11f16c0..d88bdd542 100644 --- a/charon-ml/src/generated/Generated_Types.ml +++ b/charon-ml/src/generated/Generated_Types.ml @@ -8,8 +8,8 @@ code-generation code is in `charon/src/bin/generate-ml`. *) open Identifiers -open Meta -open Values +open Generated_Meta +open Generated_Values module TypeVarId = IdGen () module TypeDeclId = IdGen () module VariantId = IdGen () @@ -459,6 +459,16 @@ and lifetime_mutability = (** .0 outlives .1 *) and ('a0, 'a1) outlives_pred = 'a0 * 'a1 +(** Where a given predicate came from. *) +and predicate_origin = + | WhereClauseOnFn + | WhereClauseOnType + | WhereClauseOnImpl + | TraitSelf + | WhereClauseOnTrait + | TraitItem of trait_item_name + | OriginDyn (** Clauses that are part of a [dyn Trait] type. *) + and provenance = | ProvGlobal of global_decl_ref | ProvFunction of fun_decl_ref @@ -525,6 +535,9 @@ and trait_param = { (** Index identifying the clause among other clauses bound at the same level. *) span : span option; + origin : predicate_origin; + (** Where the predicate was written, relative to the item that requires + it. *) trait : trait_decl_ref region_binder; (** The trait that is implemented. *) } @@ -850,10 +863,43 @@ and item_meta = { is_local : bool; (** [true] if the type decl is a local type decl, [false] if it comes from an external crate. *) + opacity : item_opacity; + (** Whether this item is considered opaque. For function and globals, this + means we don't translate the body (the code); for ADTs, this means we + don't translate the fields/variants. For traits and trait impls, this + doesn't change anything. For modules, this means we don't explore its + contents (we still translate any of its items mentioned from somewhere + else). + + This can happen either if the item was annotated with + [#[charon::opaque]] or if it was declared opaque via a command-line + argument. *) lang_item : string option; (** If the item is built-in, record its internal builtin identifier. *) } +and item_opacity = + | Transparent (** Translate the item fully. *) + | Foreign + (** Translate the item depending on the normal rust visibility of its + contents: for types, we translate fully if it is a struct with public + fields or an enum; for other items this is equivalent to [Opaque]. *) + | ItemOpaque + (** Translate the item name and signature, but not its contents. For + function and globals, this means we don't translate the body (the + code); for ADTs, this means we don't translate the fields/variants. + For traits and trait impls, this doesn't change anything. For modules, + this means we don't explore its contents (we still translate any of + its items mentioned from somewhere else). + + This can happen either if the item was annotated with + [#[charon::opaque]] or if it was declared opaque via a command-line + argument. *) + | Invisible + (** Translate nothing of this item. The corresponding map will not have an + entry for the [ItemId]. Useful when even the signature of the item + causes errors. *) + (** Item kind: whether this function/const is part of a trait declaration, trait implementation, or neither. diff --git a/charon-ml/src/generated/Generated_UllbcAst.ml b/charon-ml/src/generated/Generated_UllbcAst.ml index 960a0b4ca..d0cc17bf3 100644 --- a/charon-ml/src/generated/Generated_UllbcAst.ml +++ b/charon-ml/src/generated/Generated_UllbcAst.ml @@ -1,9 +1,9 @@ -open Types -open Values -open Expressions -open Meta +open Generated_Types +open Generated_Values +open Generated_Expressions +open Generated_Meta +open Generated_GAst open Identifiers -open GAst module BlockId = IdGen () type block = { statements : statement list; terminator : terminator } diff --git a/charon-ml/src/generated/Generated_UllbcOfJson.ml b/charon-ml/src/generated/Generated_UllbcOfJson.ml deleted file mode 100644 index 5976bcdfc..000000000 --- a/charon-ml/src/generated/Generated_UllbcOfJson.ml +++ /dev/null @@ -1,165 +0,0 @@ -open OfJsonBasic -open Types -open Expressions -open UllbcAst -open GAstOfJson - -let rec ___ = () - -and block_of_json (ctx : of_json_ctx) (js : json) : (block, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("statements", statements); ("terminator", terminator) ] -> - let* statements = list_of_json statement_of_json ctx statements in - let* terminator = terminator_of_json ctx terminator in - Ok ({ statements; terminator } : block) - | _ -> Error "") - -and block_id_of_json (ctx : of_json_ctx) (js : json) : (block_id, string) result - = - combine_error_msgs js __FUNCTION__ - (match js with - | x -> BlockId.id_of_json ctx x - | _ -> Error "") - -and statement_of_json (ctx : of_json_ctx) (js : json) : - (statement, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ ("span", span); ("kind", kind); ("comments_before", comments_before) ] - -> - let* span = span_of_json ctx span in - let* kind = statement_kind_of_json ctx kind in - let* comments_before = - list_of_json string_of_json ctx comments_before - in - Ok ({ span; kind; comments_before } : statement) - | _ -> Error "") - -and statement_kind_of_json (ctx : of_json_ctx) (js : json) : - (statement_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Assign", `List [ x_0; x_1 ]) ] -> - let* x_0 = place_of_json ctx x_0 in - let* x_1 = rvalue_of_json ctx x_1 in - Ok (Assign (x_0, x_1)) - | `Assoc [ ("SetDiscriminant", `List [ x_0; x_1 ]) ] -> - let* x_0 = place_of_json ctx x_0 in - let* x_1 = variant_id_of_json ctx x_1 in - Ok (SetDiscriminant (x_0, x_1)) - | `Assoc [ ("CopyNonOverlapping", copy_non_overlapping) ] -> - let* copy_non_overlapping = - box_of_json copy_non_overlapping_of_json ctx copy_non_overlapping - in - Ok (CopyNonOverlapping copy_non_overlapping) - | `Assoc [ ("StorageLive", storage_live) ] -> - let* storage_live = local_id_of_json ctx storage_live in - Ok (StorageLive storage_live) - | `Assoc [ ("StorageDead", storage_dead) ] -> - let* storage_dead = local_id_of_json ctx storage_dead in - Ok (StorageDead storage_dead) - | `Assoc [ ("PlaceMention", place_mention) ] -> - let* place_mention = place_of_json ctx place_mention in - Ok (PlaceMention place_mention) - | `Assoc - [ - ("Assert", `Assoc [ ("assert", assert_); ("on_failure", on_failure) ]); - ] -> - let* assert_ = assertion_of_json ctx assert_ in - let* on_failure = abort_kind_of_json ctx on_failure in - Ok (Assert (assert_, on_failure)) - | `String "Nop" -> Ok Nop - | _ -> Error "") - -and switch_of_json (ctx : of_json_ctx) (js : json) : (switch, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("If", `List [ x_0; x_1 ]) ] -> - let* x_0 = block_id_of_json ctx x_0 in - let* x_1 = block_id_of_json ctx x_1 in - Ok (If (x_0, x_1)) - | `Assoc [ ("SwitchInt", `List [ x_0; x_1; x_2 ]) ] -> - let* x_0 = literal_type_of_json ctx x_0 in - let* x_1 = - list_of_json (pair_of_json literal_of_json block_id_of_json) ctx x_1 - in - let* x_2 = block_id_of_json ctx x_2 in - Ok (SwitchInt (x_0, x_1, x_2)) - | _ -> Error "") - -and terminator_of_json (ctx : of_json_ctx) (js : json) : - (terminator, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc - [ ("span", span); ("kind", kind); ("comments_before", comments_before) ] - -> - let* span = span_of_json ctx span in - let* kind = terminator_kind_of_json ctx kind in - let* comments_before = - list_of_json string_of_json ctx comments_before - in - Ok ({ span; kind; comments_before } : terminator) - | _ -> Error "") - -and terminator_kind_of_json (ctx : of_json_ctx) (js : json) : - (terminator_kind, string) result = - combine_error_msgs js __FUNCTION__ - (match js with - | `Assoc [ ("Goto", `Assoc [ ("target", target) ]) ] -> - let* target = block_id_of_json ctx target in - Ok (Goto target) - | `Assoc [ ("Switch", `Assoc [ ("discr", discr); ("targets", targets) ]) ] - -> - let* discr = operand_of_json ctx discr in - let* targets = switch_of_json ctx targets in - Ok (Switch (discr, targets)) - | `Assoc - [ - ( "Call", - `Assoc - [ ("call", call); ("target", target); ("on_unwind", on_unwind) ] - ); - ] -> - let* call = call_of_json ctx call in - let* target = block_id_of_json ctx target in - let* on_unwind = block_id_of_json ctx on_unwind in - Ok (Call (call, target, on_unwind)) - | `Assoc - [ - ( "Drop", - `Assoc - [ - ("kind", kind); - ("place", place); - ("tref", tref); - ("target", target); - ("on_unwind", on_unwind); - ] ); - ] -> - let* kind = drop_kind_of_json ctx kind in - let* place = place_of_json ctx place in - let* tref = trait_ref_of_json ctx tref in - let* target = block_id_of_json ctx target in - let* on_unwind = block_id_of_json ctx on_unwind in - Ok (Drop (kind, place, tref, target, on_unwind)) - | `Assoc - [ - ( "Assert", - `Assoc - [ - ("assert", assert_); ("target", target); ("on_unwind", on_unwind); - ] ); - ] -> - let* assert_ = assertion_of_json ctx assert_ in - let* target = block_id_of_json ctx target in - let* on_unwind = block_id_of_json ctx on_unwind in - Ok (TAssert (assert_, target, on_unwind)) - | `Assoc [ ("Abort", abort) ] -> - let* abort = abort_kind_of_json ctx abort in - Ok (Abort abort) - | `String "Return" -> Ok Return - | `String "UnwindResume" -> Ok UnwindResume - | _ -> Error "") diff --git a/charon-ml/tests/Test_Deserialize.ml b/charon-ml/tests/Test_Deserialize.ml index 1caa872c6..a0af1c379 100644 --- a/charon-ml/tests/Test_Deserialize.ml +++ b/charon-ml/tests/Test_Deserialize.ml @@ -48,7 +48,7 @@ let run_tests (folder : string) : unit = log#ldebug (lazy ("Deserializing LLBC file: " ^ file)); (* Load the module *) let json = Yojson.Basic.from_file file in - match LlbcOfJson.crate_of_json json with + match OfJson.crate_of_json json with | Error s -> log#error "Error when deserializing file %s: %s\n" file s; exit 1 @@ -57,12 +57,11 @@ let run_tests (folder : string) : unit = (* Test discriminant/tag roundtrip *) let print_ctx = PrintUtils.of_crate m in let print_var_id_opt = function - | Some v -> - "Some (" ^ PrintTypes.variant_id_to_pretty_string v ^ ")" + | Some v -> "Some (" ^ Print.variant_id_to_pretty_string v ^ ")" | None -> "None" in let print_scalar_value_opt = function - | Some v -> "Some " ^ PrintValues.scalar_value_to_string v + | Some v -> "Some " ^ Print.scalar_value_to_string v | None -> "None" in let ptr_size = @@ -74,7 +73,7 @@ let run_tests (folder : string) : unit = | Enum _, [ (_, layout) ] when Option.is_some layout.discriminant_layout -> begin let name = - PrintTypes.name_to_string print_ctx ty_decl.item_meta.name + Print.name_to_string print_ctx ty_decl.item_meta.name in Types.VariantId.iteri (fun var_id _ -> @@ -101,7 +100,7 @@ let run_tests (folder : string) : unit = | _ -> () (* Not an enum *)) m.type_decls; (* Test that pretty-printing doesn't crash *) - let printed = PrintLlbcAst.Crate.crate_to_string m in + let printed = Print.crate_to_string m in log#ldebug (lazy ("\n" ^ printed ^ "\n"))) llbc_files in diff --git a/charon-ml/tests/Test_NameMatcher.ml b/charon-ml/tests/Test_NameMatcher.ml index 09ad1ca28..302f5a011 100644 --- a/charon-ml/tests/Test_NameMatcher.ml +++ b/charon-ml/tests/Test_NameMatcher.ml @@ -1,6 +1,7 @@ open Charon open Charon.LlbcAst open Charon.Meta +open Charon.GAstUtils open Logging open NameMatcher @@ -73,15 +74,15 @@ module PatternTest = struct } type env = { - ctx : LlbcAst.block ctx; + ctx : ctx; file_name : string; match_config : match_config; - fmt_env : PrintLlbcAst.fmt_env; + fmt_env : Print.fmt_env; print_config : print_config; to_pat_config : to_pat_config; } - let mk_env (ctx : LlbcAst.block ctx) file_name : env = + let mk_env (ctx : ctx) file_name : env = let tgt = TkPattern in let match_with_trait_decl_refs = true in { @@ -98,7 +99,7 @@ module PatternTest = struct let fail () = failwith ("Couldn't parse attribute: `" - ^ PrintTypes.raw_attribute_to_string attribute + ^ Print.raw_attribute_to_string attribute ^ "`") in let is_pattern_test = @@ -155,12 +156,9 @@ module PatternTest = struct and list_block_calls (blk : block) : call list = List.concat_map list_stmt_calls blk.statements in - let body = - match decl.body with - | Body body -> body - | _ -> failwith "Expected a function body with contents" + let calls = + list_block_calls (body_as_structured_exn decl.body).body in - let calls = list_block_calls body.body in let fn_ptrs = List.map (fun call -> @@ -202,7 +200,7 @@ module PatternTest = struct else if (not test.success) && match_success then ( log#error "Pattern %s matches function %s but shouldn't\n" (pattern_to_string env.print_config (Option.get test.pattern)) - (PrintTypes.name_to_string env.fmt_env decl.item_meta.name); + (Print.name_to_string env.fmt_env decl.item_meta.name); false) else if test.success && not pattern_to_name_success then ( let pattern, name = Option.get pattern_name in @@ -226,7 +224,7 @@ let annotated_rust_tests test_file = log#ldebug (lazy ("Deserializing LLBC file: " ^ test_file)); let json = Yojson.Basic.from_file test_file in let (crate : crate) = - match LlbcOfJson.crate_of_json json with + match OfJson.crate_of_json json with | Error s -> log#error "Error when deserializing file %s: %s\n" test_file s; exit 1 diff --git a/charon-ml/tests/Tests.ml b/charon-ml/tests/Tests.ml index 88752d9db..da0639cb5 100644 --- a/charon-ml/tests/Tests.ml +++ b/charon-ml/tests/Tests.ml @@ -6,6 +6,7 @@ module EL = Easy_logging.Logging let log = main_log let () = + Printexc.record_backtrace true; try let _ = Unix.getenv "CHARON_LOG" in log#set_level EL.Debug diff --git a/charon/Cargo.lock b/charon/Cargo.lock index 1c4789129..bd01849c7 100644 --- a/charon/Cargo.lock +++ b/charon/Cargo.lock @@ -243,7 +243,7 @@ checksum = "9555578bc9e57714c812a1f84e4fc5b4d21fcb063490c624de019f7464c91268" [[package]] name = "charon" -version = "0.1.183" +version = "0.1.184" dependencies = [ "annotate-snippets", "anstream", diff --git a/charon/Cargo.toml b/charon/Cargo.toml index f24199f1d..58cc95d7b 100644 --- a/charon/Cargo.toml +++ b/charon/Cargo.toml @@ -24,7 +24,7 @@ tracing = { version = "0.1", features = ["max_level_trace"] } [package] name = "charon" -version = "0.1.183" +version = "0.1.184" authors.workspace = true edition.workspace = true license.workspace = true diff --git a/charon/src/ast/gast.rs b/charon/src/ast/gast.rs index ec7ee8138..49da83586 100644 --- a/charon/src/ast/gast.rs +++ b/charon/src/ast/gast.rs @@ -83,6 +83,7 @@ pub struct GExprBody { EnumToGetters, )] #[serde_state(state_implements = HashConsSerializerState)] +#[charon::variants_suffix("Body")] pub enum Body { /// Body represented as a CFG. This is what ullbc is made of, and what we get after translating MIR. Unstructured(ullbc_ast::ExprBody), diff --git a/charon/src/ast/krate.rs b/charon/src/ast/krate.rs index e20ae1dad..9f38dd873 100644 --- a/charon/src/ast/krate.rs +++ b/charon/src/ast/krate.rs @@ -192,6 +192,12 @@ pub struct TranslatedCrate { #[serde(with = "SeqHashMapToArray::")] pub target_information: SeqHashMap, + /// The translated files. This field must come before any field containing spans, + /// as the OCaml deserialization of spans requires the files to be deserialized already. + #[drive(skip)] + #[serde_state(stateless)] + pub files: IndexVec, + /// The names of all registered items. Available so we can know the names even of items that /// failed to translate. /// Invariant: after translation, any existing `ItemId` must have an associated name, even @@ -202,10 +208,6 @@ pub struct TranslatedCrate { #[serde(with = "SeqHashMapToArray::")] pub short_names: SeqHashMap, - /// The translated files. - #[drive(skip)] - #[serde_state(stateless)] - pub files: IndexVec, /// The translated type definitions pub type_decls: IndexMap, /// The translated function definitions diff --git a/charon/src/ast/meta.rs b/charon/src/ast/meta.rs index 924166d6e..acc2b6a9b 100644 --- a/charon/src/ast/meta.rs +++ b/charon/src/ast/meta.rs @@ -203,6 +203,7 @@ pub enum ItemOpacity { /// /// This can happen either if the item was annotated with `#[charon::opaque]` or if it was /// declared opaque via a command-line argument. + #[charon::rename("ItemOpaque")] Opaque, /// Translate nothing of this item. The corresponding map will not have an entry for the /// `ItemId`. Useful when even the signature of the item causes errors. @@ -232,7 +233,6 @@ pub struct ItemMeta { /// /// This can happen either if the item was annotated with `#[charon::opaque]` or if it was /// declared opaque via a command-line argument. - #[charon::opaque] #[drive(skip)] pub opacity: ItemOpacity, /// If the item is built-in, record its internal builtin identifier. @@ -259,6 +259,9 @@ pub enum FileName { Debug, PartialEq, Eq, Clone, Hash, PartialOrd, Ord, Serialize, Deserialize, Drive, DriveMut, )] pub struct File { + /// The file identifier. + #[charon::opaque] + pub id: FileId, /// The path to the file. pub name: FileName, /// Name of the crate this file comes from. diff --git a/charon/src/ast/names_utils.rs b/charon/src/ast/names_utils.rs index 76c0995fb..1a68d100b 100644 --- a/charon/src/ast/names_utils.rs +++ b/charon/src/ast/names_utils.rs @@ -95,4 +95,10 @@ impl Name { } self } + + /// Get the last identifier of the name, if any. This is useful for error messages and such. + /// Panics if the name is empty or if the last element is not an identifier. + pub fn short_str(&self) -> &String { + self.name.last().unwrap().as_ident().unwrap().0 + } } diff --git a/charon/src/ast/types.rs b/charon/src/ast/types.rs index 12a7337df..2a8e870cf 100644 --- a/charon/src/ast/types.rs +++ b/charon/src/ast/types.rs @@ -336,6 +336,7 @@ pub enum PredicateOrigin { // ``` TraitItem(TraitItemName), /// Clauses that are part of a `dyn Trait` type. + #[charon::rename("OriginDyn")] Dyn, } diff --git a/charon/src/ast/types/vars.rs b/charon/src/ast/types/vars.rs index 34dec092b..13afa157c 100644 --- a/charon/src/ast/types/vars.rs +++ b/charon/src/ast/types/vars.rs @@ -147,7 +147,6 @@ pub struct TraitParam { // TODO: does not need to be an option. pub span: Option, /// Where the predicate was written, relative to the item that requires it. - #[charon::opaque] #[drive(skip)] pub origin: PredicateOrigin, /// The trait that is implemented. diff --git a/charon/src/bin/charon-driver/translate/translate_meta.rs b/charon/src/bin/charon-driver/translate/translate_meta.rs index ef68e96d7..a4962f7b9 100644 --- a/charon/src/bin/charon-driver/translate/translate_meta.rs +++ b/charon/src/bin/charon-driver/translate/translate_meta.rs @@ -23,12 +23,12 @@ impl<'tcx> TranslateCtx<'tcx> { None => { let source_file = self.tcx.sess.source_map().lookup_source_file(span.lo()); let crate_name = self.tcx.crate_name(source_file.cnum).to_string(); - let file = File { + let id = self.translated.files.push_with(|id| File { + id, name: filename.clone(), crate_name, contents: source_file.src.as_deref().cloned(), - }; - let id = self.translated.files.push(file); + }); self.file_to_id.insert(filename, id); id } diff --git a/charon/src/bin/generate-ml/main.rs b/charon/src/bin/generate-ml/main.rs index 6b32c7ae2..2af57908c 100644 --- a/charon/src/bin/generate-ml/main.rs +++ b/charon/src/bin/generate-ml/main.rs @@ -11,94 +11,44 @@ use anyhow::{Context, Result, bail}; use assert_cmd::cargo::CommandCargoExt; use charon_lib::ast::*; -use convert_case::{Case, Casing}; -use indoc::indoc; use itertools::Itertools; use std::collections::{HashMap, HashSet}; -use std::fmt::Write; use std::fs; use std::path::PathBuf; use std::process::Command; -/// `Name` is a complex datastructure; to inspect it we serialize it a little bit. -fn repr_name(_crate_data: &TranslatedCrate, n: &Name) -> String { - n.name - .iter() - .map(|path_elem| match path_elem { - PathElem::Ident(i, _) => i.clone(), - PathElem::Impl(..) => "".to_string(), - PathElem::Instantiated(..) => "".to_string(), - PathElem::Target(target) => target.clone(), - }) - .join("::") -} +use crate::to_ocaml_ty::DeriveVisitors; +use crate::util::*; -fn make_ocaml_ident(name: &str) -> String { - let mut name = name.to_case(Case::Snake); - if matches!( - &*name, - "assert" - | "bool" - | "char" - | "end" - | "float" - | "fun" - | "function" - | "include" - | "let" - | "method" - | "open" - | "rec" - | "struct" - | "to" - | "type" - | "virtual" - ) { - name += "_"; - } - name -} -fn type_name_to_ocaml_ident(item_meta: &ItemMeta) -> String { - let name = item_meta - .attr_info - .rename - .as_ref() - .unwrap_or(item_meta.name.name.last().unwrap().as_ident().unwrap().0); - make_ocaml_ident(name) -} +mod of_json; +mod to_ocaml_ty; +mod util; struct GenerateCtx<'a> { crate_data: &'a TranslatedCrate, name_to_type: HashMap, /// For each type, list the types it contains. type_tree: HashMap>, - manual_type_impls: HashMap, - manual_json_impls: HashMap, - opaque_for_visitor: HashSet, + /// For types that may be ambiguous in OCaml, the generated module name to prefix to them, + /// along with the "short" module name for other generators + ambiguous_types: HashMap, + /// The current module name being compiled. + current_module: Option, + /// The list of types currently being generated. + current_ids: Vec, + /// The OCaml ident for the item currently being generated; this matters for + /// TranslatedCrate, where we treat IndexMap differently. + current_item: Option, } impl<'a> GenerateCtx<'a> { - fn new( - crate_data: &'a TranslatedCrate, - manual_type_impls: &[(&str, &str)], - manual_json_impls: &[(&str, &str)], - opaque_for_visitor: &[&str], - ) -> Self { + fn new(crate_data: &'a TranslatedCrate, ambiguous_types: &[(&str, (&str, &str))]) -> Self { let mut name_to_type: HashMap = Default::default(); let mut type_tree = HashMap::default(); for ty in &crate_data.type_decls { - let long_name = repr_name(crate_data, &ty.item_meta.name); + let long_name = repr_name(&ty.item_meta.name); if long_name.starts_with("charon_lib") { - let short_name = ty - .item_meta - .name - .name - .last() - .unwrap() - .as_ident() - .unwrap() - .0 - .clone(); + let short_name = ty.item_meta.name.short_str().clone(); name_to_type.insert(short_name, ty); } name_to_type.insert(long_name, ty); @@ -114,790 +64,19 @@ impl<'a> GenerateCtx<'a> { crate_data, name_to_type, type_tree, - manual_type_impls: Default::default(), - manual_json_impls: Default::default(), - opaque_for_visitor: Default::default(), + ambiguous_types: Default::default(), + current_module: None, + current_ids: vec![], + current_item: None, }; - ctx.manual_type_impls = manual_type_impls - .iter() - .map(|(name, def)| (ctx.id_from_name(name), def.to_string())) - .collect(); - ctx.manual_json_impls = manual_json_impls - .iter() - .map(|(name, def)| (ctx.id_from_name(name), def.to_string())) - .collect(); - ctx.opaque_for_visitor = opaque_for_visitor - .iter() - .map(|name| ctx.id_from_name(name)) - .collect(); - ctx - } - - fn id_from_name(&self, name: &str) -> TypeDeclId { - self.name_to_type - .get(name) - .unwrap_or_else(|| panic!("Name not found: `{name}`")) - .def_id - } - - /// List the (recursive) children of this type. - fn children_of(&self, name: &str) -> HashSet { - let start_id = self.id_from_name(name); - self.children_of_inner(vec![start_id], |_| true) - } - - /// List the (recursive) children of the type, except those that are only reachable through - /// `except`. - fn children_of_except(&self, name: &str, except: &[&str]) -> HashSet { - let start_id = self.id_from_name(name); - let except: HashSet<_> = except.iter().map(|name| self.id_from_name(name)).collect(); - self.children_of_inner(vec![start_id], |id| !except.contains(&id)) - } - - /// List the (recursive) children of these types. - fn children_of_many(&self, names: &[&str]) -> HashSet { - self.children_of_inner( - names.iter().map(|name| self.id_from_name(name)).collect(), - |_| true, - ) - } - - fn children_of_inner( - &self, - ty: Vec, - explore: impl Fn(TypeDeclId) -> bool, - ) -> HashSet { - let mut children = HashSet::new(); - let mut stack = ty.to_vec(); - while let Some(id) = stack.pop() { - if !children.contains(&id) - && explore(id) - && self - .crate_data - .type_decls - .get(id) - .is_some_and(|decl| decl.item_meta.is_local) - { - children.insert(id); - if let Some(contained) = self.type_tree.get(&id) { - stack.extend(contained); - } - } - } - children - } -} - -/// Converts a type to the appropriate `*_of_json` call. In case of generics, this combines several -/// functions, e.g. `list_of_json bool_of_json`. -fn type_to_ocaml_call(ctx: &GenerateCtx, ty: &Ty) -> String { - match ty.kind() { - TyKind::Literal(LiteralTy::Bool) => "bool_of_json".to_string(), - TyKind::Literal(LiteralTy::Char) => "char_of_json".to_string(), - TyKind::Literal(LiteralTy::Int(int_ty)) => match int_ty { - // Even though OCaml ints are only 63 bits, only scalars with their 128 bits should be able to become too large - IntTy::I128 => "big_int_of_json".to_string(), - _ => "int_of_json".to_string(), - }, - TyKind::Literal(LiteralTy::UInt(uint_ty)) => match uint_ty { - // Even though OCaml ints are only 63 bits, only scalars with their 128 bits should be able to become too large - UIntTy::U128 => "big_int_of_json".to_string(), - _ => "int_of_json".to_string(), - }, - TyKind::Literal(LiteralTy::Float(_)) => "float_of_json".to_string(), - TyKind::Adt(tref) => { - let mut expr = Vec::new(); - for ty in &tref.generics.types { - expr.push(type_to_ocaml_call(ctx, ty)) - } - match tref.id { - TypeId::Adt(id) => { - let mut first = if let Some(tdecl) = ctx.crate_data.type_decls.get(id) { - type_name_to_ocaml_ident(&tdecl.item_meta) - } else { - format!("missing_type_{id}") - }; - if first == "vec" { - first = "list".to_string(); - } - if first == "ustr" { - first = "string".to_string(); - } - if first == "index_map" { - // That's the `indexmap::IndexMap` case. Pass something dummy for the - // `RandomState` parameter. - expr[2] = "int_of_json".to_string(); - } - expr.insert(0, first + "_of_json"); - } - TypeId::Builtin(BuiltinTy::Box) => expr.insert(0, "box_of_json".to_owned()), - TypeId::Tuple => { - let name = match tref.generics.types.len() { - 2 => "pair_of_json".to_string(), - 3 => "triple_of_json".to_string(), - len => format!("tuple_{len}_of_json"), - }; - expr.insert(0, name); - } - _ => unimplemented!("{ty:?}"), - } - expr.into_iter().map(|f| format!("({f})")).join(" ") - } - TyKind::TypeVar(DeBruijnVar::Free(id)) => format!("arg{id}_of_json"), - _ => unimplemented!("{ty:?}"), - } -} -/// Converts a type to the appropriate ocaml name. In case of generics, this provides appropriate -/// parameters. -fn type_to_ocaml_name(ctx: &GenerateCtx, ty: &Ty) -> String { - match ty.kind() { - TyKind::Literal(LiteralTy::Bool) => "bool".to_string(), - TyKind::Literal(LiteralTy::Char) => "(Uchar.t [@visitors.opaque])".to_string(), - TyKind::Literal(LiteralTy::Int(int_ty)) => match int_ty { - // Even though OCaml ints are only 63 bits, only scalars with their 128 bits should be able to become too large - IntTy::I128 => "big_int".to_string(), - _ => "int".to_string(), - }, - TyKind::Literal(LiteralTy::UInt(uint_ty)) => match uint_ty { - // Even though OCaml ints are only 63 bits, only scalars with their 128 bits should be able to become too large - UIntTy::U128 => "big_int".to_string(), - _ => "int".to_string(), - }, - TyKind::Literal(LiteralTy::Float(_)) => "float_of_json".to_string(), - TyKind::Adt(tref) => { - let mut args = tref - .generics - .types - .iter() - .map(|ty| type_to_ocaml_name(ctx, ty)) - .map(|name| { - if !name.chars().all(|c| c.is_alphanumeric()) { - format!("({name})") - } else { - name - } - }) - .collect_vec(); - match tref.id { - TypeId::Adt(id) => { - let mut base_ty = if let Some(tdecl) = ctx.crate_data.type_decls.get(id) { - type_name_to_ocaml_ident(&tdecl.item_meta) - } else if let Some(name) = ctx.crate_data.item_name(id) { - eprintln!( - "Warning: type {} missing from llbc", - repr_name(ctx.crate_data, name) - ); - name.name - .last() - .unwrap() - .as_ident() - .unwrap() - .0 - .to_lowercase() - } else { - format!("missing_type_{id}") - }; - if base_ty == "vec" { - base_ty = "list".to_string(); - } - if base_ty == "ustr" { - base_ty = "string".to_string(); - } - if base_ty == "indexed_map" || base_ty == "index_vec" { - base_ty = "list".to_string(); - args.remove(0); // Remove the index generic param - } - if base_ty == "index_map" { - // That's the `indexmap::IndexMap` case. Translate as a list of pairs. - base_ty = "list".to_string(); - args = vec![format!("( {} * {} )", args[0], args[1])] - } - let args = match args.as_slice() { - [] => String::new(), - [arg] => arg.clone(), - args => format!("({})", args.iter().join(",")), - }; - format!("{args} {base_ty}") - } - TypeId::Builtin(BuiltinTy::Box) => args[0].clone(), - TypeId::Tuple => args.iter().join("*"), - _ => unimplemented!("{ty:?}"), - } - } - TyKind::TypeVar(DeBruijnVar::Free(id) | DeBruijnVar::Bound(_, id)) => format!("'a{id}"), - _ => unimplemented!("{ty:?}"), - } -} - -fn convert_vars<'a>(ctx: &GenerateCtx, fields: impl IntoIterator) -> String { - fields - .into_iter() - .filter(|f| !f.is_opaque()) - .map(|f| { - let name = make_ocaml_ident(f.name.as_deref().unwrap()); - let rename = make_ocaml_ident(f.renamed_name().unwrap()); - let convert = type_to_ocaml_call(ctx, &f.ty); - format!("let* {rename} = {convert} ctx {name} in") - }) - .join("\n") -} - -fn build_branch<'a>( - ctx: &GenerateCtx, - pat: &str, - fields: impl IntoIterator, - construct: &str, -) -> String { - let convert = convert_vars(ctx, fields); - format!("| {pat} -> {convert} Ok ({construct})") -} - -fn build_function(ctx: &GenerateCtx, decl: &TypeDecl, branches: &str) -> String { - let ty = TyKind::Adt(TypeDeclRef { - id: TypeId::Adt(decl.def_id), - generics: decl.generics.identity_args().into(), - }) - .into_ty(); - let ty_name = type_name_to_ocaml_ident(&decl.item_meta); - let ty = type_to_ocaml_name(ctx, &ty); - let signature = if decl.generics.types.is_empty() { - format!("{ty_name}_of_json (ctx : of_json_ctx) (js : json) : ({ty}, string) result =") - } else { - let types = &decl.generics.types; - let gen_vars_space = types + ctx.ambiguous_types = ambiguous_types .iter() - .enumerate() - .map(|(i, _)| format!("'a{i}")) - .join(" "); - - let mut args = Vec::new(); - let mut ty_args = Vec::new(); - for (i, _) in types.iter().enumerate() { - args.push(format!("arg{i}_of_json")); - ty_args.push(format!("(of_json_ctx -> json -> ('a{i}, string) result)")); - } - args.push("ctx".to_string()); - ty_args.push("of_json_ctx".to_string()); - args.push("js".to_string()); - ty_args.push("json".to_string()); - - let ty_args = ty_args.into_iter().join(" -> "); - let args = args.into_iter().join(" "); - let fun_ty = format!("{gen_vars_space}. {ty_args} -> ({ty}, string) result"); - format!("{ty_name}_of_json : {fun_ty} = fun {args} ->") - }; - format!( - r#" - and {signature} - combine_error_msgs js __FUNCTION__ - (match js with{branches} | _ -> Error "") - "# - ) -} - -fn type_decl_to_json_deserializer(ctx: &GenerateCtx, decl: &TypeDecl) -> String { - let return_ty = type_name_to_ocaml_ident(&decl.item_meta); - let return_ty = if decl.generics.types.is_empty() { - return_ty - } else { - format!("_ {return_ty}") - }; - - let branches = match &decl.kind { - _ if let Some(def) = ctx.manual_json_impls.get(&decl.def_id) => format!("| json -> {def}"), - TypeDeclKind::Struct(fields) if fields.is_empty() => { - build_branch(ctx, "`Null", fields, "()") - } - TypeDeclKind::Struct(fields) - if fields.len() == 1 && fields[0].name.as_ref().is_some_and(|name| name == "_raw") => - { - // These are the special strongly-typed integers. - let short_name = decl - .item_meta - .name - .name - .last() - .unwrap() - .as_ident() - .unwrap() - .0 - .clone(); - format!("| x -> {short_name}.id_of_json ctx x") - } - TypeDeclKind::Struct(fields) - if fields.len() == 1 - && (fields[0].name.is_none() - || decl - .item_meta - .attr_info - .attributes - .iter() - .filter_map(|a| a.as_unknown()) - .any(|a| a.to_string() == "serde(transparent)")) => - { - let ty = &fields[0].ty; - let call = type_to_ocaml_call(ctx, ty); - format!("| x -> {call} ctx x") - } - TypeDeclKind::Alias(ty) => { - let call = type_to_ocaml_call(ctx, ty); - format!("| x -> {call} ctx x") - } - TypeDeclKind::Struct(fields) if fields.iter().all(|f| f.name.is_none()) => { - let mut fields = fields.clone(); - for (i, f) in fields.iter_mut().enumerate() { - f.name = Some(format!("x{i}")); - } - let pat: String = fields - .iter() - .map(|f| f.name.as_deref().unwrap()) - .map(make_ocaml_ident) - .join(";"); - let pat = format!("`List [ {pat} ]"); - let construct = fields - .iter() - .map(|f| f.renamed_name().unwrap()) - .map(make_ocaml_ident) - .join(", "); - let construct = format!("( {construct} )"); - build_branch(ctx, &pat, &fields, &construct) - } - TypeDeclKind::Struct(fields) => { - let fields = fields - .iter() - .filter(|field| { - !field - .attr_info - .attributes - .iter() - .filter_map(|a| a.as_unknown()) - .any(|a| a.to_string() == "serde(skip)") - }) - .collect_vec(); - let pat: String = fields - .iter() - .map(|f| { - let name = f.name.as_ref().unwrap(); - let var = if f.is_opaque() { - "_" - } else { - &make_ocaml_ident(name) - }; - format!("(\"{name}\", {var});") - }) - .join("\n"); - let pat = format!("`Assoc [ {pat} ]"); - let construct = fields - .iter() - .filter(|f| !f.is_opaque()) - .map(|f| f.renamed_name().unwrap()) - .map(make_ocaml_ident) - .join("; "); - let construct = format!("({{ {construct} }} : {return_ty})"); - build_branch(ctx, &pat, fields, &construct) - } - TypeDeclKind::Enum(variants) => { - variants - .iter() - .filter(|v| !v.is_opaque()) - .map(|variant| { - let name = &variant.name; - let rename = variant.renamed_name(); - if variant.fields.is_empty() { - // Unit variant - let pat = format!("`String \"{name}\""); - build_branch(ctx, &pat, &variant.fields, rename) - } else { - let mut fields = variant.fields.clone(); - let inner_pat = if fields.iter().all(|f| f.name.is_none()) { - // Tuple variant - if variant.fields.len() == 1 { - let var = make_ocaml_ident(&variant.name); - fields[0].name = Some(var.clone()); - var - } else { - for (i, f) in fields.iter_mut().enumerate() { - f.name = Some(format!("x_{i}")); - } - let pat = - fields.iter().map(|f| f.name.as_ref().unwrap()).join("; "); - format!("`List [ {pat} ]") - } - } else { - // Struct variant - let pat = fields - .iter() - .map(|f| { - let name = f.name.as_ref().unwrap(); - let var = if f.is_opaque() { - "_" - } else { - &make_ocaml_ident(name) - }; - format!("(\"{name}\", {var});") - }) - .join(" "); - format!("`Assoc [ {pat} ]") - }; - let pat = format!("`Assoc [ (\"{name}\", {inner_pat}) ]"); - let construct_fields = fields - .iter() - .map(|f| f.name.as_ref().unwrap()) - .map(|n| make_ocaml_ident(n)) - .join(", "); - let construct = format!("{rename} ({construct_fields})"); - build_branch(ctx, &pat, &fields, &construct) - } - }) - .join("\n") - } - TypeDeclKind::Union(..) => todo!(), - TypeDeclKind::Opaque => todo!(), - TypeDeclKind::Error(_) => todo!(), - }; - build_function(ctx, decl, &branches) -} - -fn extract_doc_comments(attr_info: &AttrInfo) -> String { - attr_info - .attributes - .iter() - .filter_map(|a| a.as_doc_comment()) - .join("\n") -} - -/// Make a doc comment that contains the given string, indenting it if necessary. -fn build_doc_comment(comment: String, indent_level: usize) -> String { - #[derive(Default)] - struct Exchanger { - is_in_open_escaped_block: bool, - is_in_open_inline_escape: bool, - } - impl Exchanger { - pub fn exchange_escape_delimiters(&mut self, line: &str) -> String { - if line.contains("```") { - // Handle multi-line escaped blocks. - let (leading, mut rest) = line.split_once("```").unwrap(); - - // Strip all (hard-coded) possible ways to open the block. - rest = if rest.starts_with("text") { - rest.strip_prefix("text").unwrap() - } else if rest.starts_with("rust,ignore") { - rest.strip_prefix("rust,ignore").unwrap() - } else { - rest - }; - let mut result = leading.to_owned(); - if self.is_in_open_escaped_block { - result.push_str("]}"); - self.is_in_open_escaped_block = false; - } else { - result.push_str("{@rust["); - self.is_in_open_escaped_block = true; - } - result.push_str(rest); - result - } else if line.contains('`') { - // Handle inline escaped strings. These can occur in multiple lines, so we track them globally. - let mut parts = line.split('`'); - // Skip after first part (we only need to add escapes after that). - let mut result = parts.next().unwrap().to_owned(); - for part in parts { - if self.is_in_open_inline_escape { - result.push(']'); - result.push_str(part); - self.is_in_open_inline_escape = false; - } else { - result.push('['); - result.push_str(part); - self.is_in_open_inline_escape = true; - } - } - result - } else { - line.to_owned() - } - } - } - - if comment.is_empty() { - return comment; - } - let is_multiline = comment.contains("\n"); - if !is_multiline { - let fixed_comment = Exchanger::default().exchange_escape_delimiters(&comment); - format!("(**{fixed_comment} *)") - } else { - let indent = " ".repeat(indent_level); - let mut exchanger = Exchanger::default(); - let comment = comment - .lines() - .enumerate() - .map(|(i, line)| { - // Remove one leading space if there is one (there usually is because we write `/// - // comment` and not `///comment`). - let line = line.strip_prefix(" ").unwrap_or(line); - let fixed_line = exchanger.exchange_escape_delimiters(line); - - // The first line follows the `(**` marker, it does not need to be indented. - // Neither do empty lines. - if i == 0 || fixed_line.is_empty() { - fixed_line - } else { - format!("{indent} {fixed_line}") - } - }) - .join("\n"); - format!("(** {comment}\n{indent} *)") - } -} - -fn build_type(_ctx: &GenerateCtx, decl: &TypeDecl, co_rec: bool, body: &str) -> String { - let ty_name = type_name_to_ocaml_ident(&decl.item_meta); - let generics = decl - .generics - .types - .iter() - .enumerate() - .map(|(i, _)| format!("'a{i}")) - .collect_vec(); - let generics = match generics.as_slice() { - [] => String::new(), - [ty] => ty.clone(), - generics => format!("({})", generics.iter().join(",")), - }; - let comment = extract_doc_comments(&decl.item_meta.attr_info); - let comment = build_doc_comment(comment, 0); - let keyword = if co_rec { "and" } else { "type" }; - format!("\n{comment} {keyword} {generics} {ty_name} = {body}") -} - -/// Generate an ocaml type declaration that mirrors `decl`. -/// -/// `co_rec` indicates whether this definition is co-recursive with the ones that come before (i.e. -/// should be declared with `and` instead of `type`). -fn type_decl_to_ocaml_decl(ctx: &GenerateCtx, decl: &TypeDecl, co_rec: bool) -> String { - let opaque = if ctx.opaque_for_visitor.contains(&decl.def_id) { - "[@visitors.opaque]" - } else { - "" - }; - let body = match &decl.kind { - _ if let Some(def) = ctx.manual_type_impls.get(&decl.def_id) => def.clone(), - TypeDeclKind::Alias(ty) => { - let ty = type_to_ocaml_name(ctx, ty); - format!("{ty} {opaque}") - } - TypeDeclKind::Struct(fields) if fields.is_empty() => "unit".to_string(), - TypeDeclKind::Struct(fields) - if fields.len() == 1 && fields[0].name.as_ref().is_some_and(|name| name == "_raw") => - { - // These are the special strongly-typed integers. - let short_name = decl - .item_meta - .name - .name - .last() - .unwrap() - .as_ident() - .unwrap() - .0 - .clone(); - format!("{short_name}.id [@visitors.opaque]") - } - TypeDeclKind::Struct(fields) - if fields.len() == 1 - && (fields[0].name.is_none() - || decl - .item_meta - .attr_info - .attributes - .iter() - .filter_map(|a| a.as_unknown()) - .any(|a| a.to_string() == "serde(transparent)")) => - { - let ty = type_to_ocaml_name(ctx, &fields[0].ty); - format!("{ty} {opaque}") - } - TypeDeclKind::Struct(fields) if fields.iter().all(|f| f.name.is_none()) => fields - .iter() - .filter(|f| !f.is_opaque()) - .map(|f| { - let ty = type_to_ocaml_name(ctx, &f.ty); - format!("{ty} {opaque}") - }) - .join("*"), - TypeDeclKind::Struct(fields) => { - let fields = fields - .iter() - .filter(|f| !f.is_opaque()) - .map(|f| { - let name = f.renamed_name().unwrap(); - let ty = type_to_ocaml_name(ctx, &f.ty); - let comment = extract_doc_comments(&f.attr_info); - let comment = build_doc_comment(comment, 2); - format!("{name} : {ty} {opaque} {comment}") - }) - .join(";"); - format!("{{ {fields} }}") - } - TypeDeclKind::Enum(variants) => { - variants - .iter() - .filter(|v| !v.is_opaque()) - .map(|variant| { - let mut attr_info = variant.attr_info.clone(); - let rename = variant.renamed_name(); - let ty = if variant.fields.is_empty() { - // Unit variant - String::new() - } else { - if variant.fields.iter().all(|f| f.name.is_some()) { - let fields = variant - .fields - .iter() - .map(|f| { - let comment = extract_doc_comments(&f.attr_info); - let description = if comment.is_empty() { - comment - } else { - format!(": {comment}") - }; - format!("\n - [{}]{description}", f.name.as_ref().unwrap()) - }) - .join(""); - let field_descriptions = format!("\n Fields:{fields}"); - // Add a constructed doc-comment - attr_info - .attributes - .push(Attribute::DocComment(field_descriptions)); - } - let fields = variant - .fields - .iter() - .map(|f| { - let ty = type_to_ocaml_name(ctx, &f.ty); - format!("{ty} {opaque}") - }) - .join("*"); - format!(" of {fields}") - }; - let comment = extract_doc_comments(&attr_info); - let comment = build_doc_comment(comment, 3); - format!("\n\n | {rename}{ty} {comment}") - }) - .join("") - } - TypeDeclKind::Union(..) => todo!(), - TypeDeclKind::Opaque => todo!(), - TypeDeclKind::Error(_) => todo!(), - }; - build_type(ctx, decl, co_rec, &body) -} - -fn generate_visitor_bases( - _ctx: &GenerateCtx, - name: &str, - inherits: &[&str], - reduce: bool, - ty_names: &[String], -) -> String { - let mut out = String::new(); - let make_inherit = |variety| { - if !inherits.is_empty() { - inherits - .iter() - .map(|ancestor| { - if let [module, name] = ancestor.split(".").collect_vec().as_slice() { - format!("inherit [_] {module}.{variety}_{name}") - } else { - format!("inherit [_] {variety}_{ancestor}") - } - }) - .join("\n") - } else { - format!("inherit [_] VisitorsRuntime.{variety}") - } - }; - - let iter_methods = ty_names - .iter() - .map(|ty| format!("method visit_{ty} : 'env -> {ty} -> unit = fun _ _ -> ()")) - .format("\n"); - let _ = write!( - &mut out, - " - class ['self] iter_{name} = - object (self : 'self) - {} - {iter_methods} - end - ", - make_inherit("iter") - ); - - let map_methods = ty_names - .iter() - .map(|ty| format!("method visit_{ty} : 'env -> {ty} -> {ty} = fun _ x -> x")) - .format("\n"); - let _ = write!( - &mut out, - " - class ['self] map_{name} = - object (self : 'self) - {} - {map_methods} - end - ", - make_inherit("map") - ); - - if reduce { - let reduce_methods = ty_names - .iter() - .map(|ty| format!("method visit_{ty} : 'env -> {ty} -> 'a = fun _ _ -> self#zero")) - .format("\n"); - let _ = write!( - &mut out, - " - class virtual ['self] reduce_{name} = - object (self : 'self) - {} - {reduce_methods} - end - ", - make_inherit("reduce") - ); + .map(|(name, (m1, m2))| (ctx.id_from_name(name), (m1.to_string(), m2.to_string()))) + .collect(); - let mapreduce_methods = ty_names - .iter() - .map(|ty| { - format!("method visit_{ty} : 'env -> {ty} -> {ty} * 'a = fun _ x -> (x, self#zero)") - }) - .format("\n"); - let _ = write!( - &mut out, - " - class virtual ['self] mapreduce_{name} = - object (self : 'self) - {} - {mapreduce_methods} - end - ", - make_inherit("mapreduce") - ); + ctx } - - out -} - -#[derive(Clone, Copy)] -struct DeriveVisitors { - name: &'static str, - ancestors: &'static [&'static str], - reduce: bool, - extra_types: &'static [&'static str], } /// The kind of code generation to perform. @@ -920,106 +99,25 @@ struct GenerateCodeFor { } impl GenerateCodeFor { - fn generate(&self, ctx: &GenerateCtx) -> Result<()> { + fn generate(&self, ctx: &mut GenerateCtx) -> Result<()> { + ctx.current_module = self + .target + .file_prefix() + .and_then(|s| s.to_str()) + .map(|s| s.to_string()); + let mut template = fs::read_to_string(&self.template) .with_context(|| format!("Failed to read template file {}", self.template.display()))?; for (i, (kind, names)) in self.markers.iter().enumerate() { let tys = names .iter() .map(|&id| &ctx.crate_data[id]) - .sorted_by_key(|tdecl| { - ( - tdecl - .item_meta - .name - .name - .last() - .unwrap() - .as_ident() - .unwrap(), - tdecl.def_id, - ) - }); + .sorted_by_key(|tdecl| (tdecl.item_meta.name.short_str(), tdecl.def_id)) + .collect::>(); + ctx.current_ids = names.iter().copied().collect(); let generated = match kind { - GenerationKind::OfJson => { - let fns = tys - .map(|ty| type_decl_to_json_deserializer(ctx, ty)) - .format("\n"); - format!("let rec ___ = ()\n{fns}") - } - GenerationKind::TypeDecl(visitors) => { - let mut decls = tys - .enumerate() - .map(|(i, ty)| { - let co_recursive = i != 0; - type_decl_to_ocaml_decl(ctx, ty, co_recursive) - }) - .join("\n"); - if let Some(visitors) = visitors { - let &DeriveVisitors { - name, - mut ancestors, - reduce, - extra_types, - } = visitors; - let varieties: &[_] = if reduce { - &["iter", "map", "reduce", "mapreduce"] - } else { - &["iter", "map"] - }; - let intermediate_visitor_name; - let intermediate_visitor_name_slice; - if !extra_types.is_empty() { - intermediate_visitor_name = format!("{name}_base"); - let intermediate_visitor = generate_visitor_bases( - ctx, - &intermediate_visitor_name, - ancestors, - reduce, - extra_types - .iter() - .map(|s| s.to_string()) - .collect_vec() - .as_slice(), - ); - intermediate_visitor_name_slice = [intermediate_visitor_name.as_str()]; - ancestors = &intermediate_visitor_name_slice; - decls = format!( - "(* Ancestors for the {name} visitors *){intermediate_visitor}\n{decls}" - ); - } - let visitors = varieties - .iter() - .map(|variety| { - let nude = if !ancestors.is_empty() { - "nude = true (* Don't inherit VisitorsRuntime *);".to_string() - } else { - String::new() - }; - let ancestors = format!( - "ancestors = [ {} ];", - ancestors - .iter() - .map(|a| format!("\"{variety}_{a}\"")) - .join(";") - ); - format!( - r#" - visitors {{ - name = "{variety}_{name}"; - monomorphic = ["env"]; - variety = "{variety}"; - {ancestors} - {nude} - }} - "# - ) - }) - .format(", "); - let _ = write!(&mut decls, "\n[@@deriving show, eq, ord, {visitors}]"); - }; - decls - } + GenerationKind::OfJson => ctx.type_decls_to_json(tys), + GenerationKind::TypeDecl(visitors) => ctx.type_decls_to_ocaml(visitors, tys), }; let placeholder = format!("(* __REPLACE{i}__ *)"); template = template.replace(&placeholder, &generated); @@ -1073,130 +171,52 @@ fn generate_ml( template_dir: PathBuf, output_dir: PathBuf, ) -> anyhow::Result<()> { - let manual_type_impls = &[ - // Hand-written because we replace the `FileId` with the corresponding file. - ("FileId", "file"), - ( - "HashConsed", - "'a0 (* Not actually hash-consed on the OCaml side *)", - ), - ]; - let manual_json_impls = &[ - // Hand-written because we interpret it as a list. - ( - "charon_lib::ids::index_vec::IndexVec", - "list_of_json arg1_of_json ctx json", - ), - // Hand-written because we interpret it as a list. - ( - "charon_lib::ids::index_map::IndexMap", - indoc!( - r#" - let* list = list_of_json (option_of_json arg1_of_json) ctx json in - Ok (List.filter_map (fun x -> x) list) - "# - ), - ), - // Hand-written because we turn it into a list of pairs. - ( - "indexmap::map::IndexMap", - "list_of_json (key_value_pair_of_json arg0_of_json arg1_of_json) ctx json", - ), - // Hand-written because we replace the `FileId` with the corresponding file name. - ( - "FileId", - indoc!( - r#" - let* file_id = FileId.id_of_json ctx json in - let file = FileId.Map.find file_id ctx.id_to_file_map in - Ok file - "#, - ), - ), - ( - "HashConsed", - r#"Error "use `hash_consed_val_of_json` instead""#, - ), // Not actually used - ( - "Ty", - "hash_consed_val_of_json ctx.ty_hashcons_map ty_kind_of_json ctx json", - ), - ( - "TraitRef", - "hash_consed_val_of_json ctx.tref_hashcons_map trait_ref_contents_of_json ctx json", - ), - ]; // Types for which we don't want to generate a type at all. let dont_generate_ty = &[ - "ItemOpacity", - "PredicateOrigin", "TraitTypeConstraintId", "charon_lib::ids::index_vec::IndexVec", "charon_lib::ids::index_map::IndexMap", ]; - // Types that we don't want visitors to go into. - let opaque_for_visitor = &["Name"]; - let ctx = GenerateCtx::new( - &crate_data, - manual_type_impls, - manual_json_impls, - opaque_for_visitor, - ); - // Items that we don't want to emit in the generated output. - let manually_implemented: HashSet<_> = [ - "ItemOpacity", - "PredicateOrigin", - "Body", - "FunDecl", - "TranslatedCrate", - ] - .iter() - .map(|name| ctx.id_from_name(name)) - .collect(); + #[rustfmt::skip] + let ambiguous_types = &[ + ("charon_lib::ast::ullbc_ast::Statement", ("Generated_UllbcAst", "Ullbc")), + ("charon_lib::ast::ullbc_ast::StatementKind", ("Generated_UllbcAst", "Ullbc")), + ("charon_lib::ast::ullbc_ast::SwitchTargets", ("Generated_UllbcAst", "Ullbc")), + ("charon_lib::ast::ullbc_ast::BlockData", ("Generated_UllbcAst", "Ullbc")), + ("charon_lib::ast::ullbc_ast::BlockId", ("Generated_UllbcAst", "Ullbc")), + ("charon_lib::ast::llbc_ast::Statement", ("Generated_LlbcAst", "Llbc")), + ("charon_lib::ast::llbc_ast::StatementKind", ("Generated_LlbcAst", "Llbc")), + ("charon_lib::ast::llbc_ast::Switch", ("Generated_LlbcAst", "Llbc")), + ("charon_lib::ast::llbc_ast::Block", ("Generated_LlbcAst", "Llbc")), + ]; + + let mut ctx = GenerateCtx::new(&crate_data, ambiguous_types); // Compute type sets for json deserializers. - let (gast_types, llbc_types, ullbc_types) = { + let mut gast_types: HashSet = HashSet::new(); + let mut llbc_types: HashSet = HashSet::new(); + let mut ullbc_types: HashSet = HashSet::new(); + let mut full_ast_types: HashSet = HashSet::new(); + { let mut all_types: HashSet<_> = ctx.children_of("TranslatedCrate"); all_types.insert(ctx.id_from_name("indexmap::map::IndexMap")); // Add this one foreign type - - // (u)llbc types are those that are dominated by the entrypoint of the corresponding - // module, i.e. those that can't be reached if you remove these entrypoints. - let non_llbc_types: HashSet<_> = - ctx.children_of_except("TranslatedCrate", &["charon_lib::ast::llbc_ast::Block"]); - let non_ullbc_types: HashSet<_> = ctx.children_of_except( - "TranslatedCrate", - &[ - "charon_lib::ast::ullbc_ast::BlockData", - "charon_lib::ast::ullbc_ast::BlockId", - ], - ); - let llbc_types: HashSet<_> = all_types.difference(&non_llbc_types).copied().collect(); - let ullbc_types: HashSet<_> = all_types.difference(&non_ullbc_types).copied().collect(); - - let shared_types: HashSet<_> = llbc_types.intersection(&ullbc_types).copied().collect(); - let llbc_types: HashSet<_> = llbc_types.difference(&shared_types).copied().collect(); - let ullbc_types: HashSet<_> = ullbc_types.difference(&shared_types).copied().collect(); - - let body_specific_types: HashSet<_> = llbc_types.union(&ullbc_types).copied().collect(); - let gast_types: HashSet<_> = all_types - .difference(&body_specific_types) - .copied() - .collect(); - - let gast_types: HashSet<_> = gast_types - .difference(&manually_implemented) - .copied() - .collect(); - let llbc_types: HashSet<_> = llbc_types - .difference(&manually_implemented) - .copied() - .collect(); - let ullbc_types: HashSet<_> = ullbc_types - .difference(&manually_implemented) - .copied() - .collect(); - (gast_types, llbc_types, ullbc_types) + let all_llbc_types: HashSet<_> = + ctx.children_of_many(&["charon_lib::ast::llbc_ast::Block"]); + let all_ullbc_types: HashSet<_> = ctx.children_of_many(&[ + "charon_lib::ast::ullbc_ast::BlockData", + "charon_lib::ast::ullbc_ast::BlockId", + ]); + all_types.into_iter().for_each(|ty| { + let in_llbc = all_llbc_types.contains(&ty); + let in_ullbc = all_ullbc_types.contains(&ty); + match (in_llbc, in_ullbc) { + (true, false) => llbc_types.insert(ty), + (false, true) => ullbc_types.insert(ty), + (true, true) => gast_types.insert(ty), + (false, false) => full_ast_types.insert(ty), + }; + }); }; let mut processed_tys: HashSet = dont_generate_ty @@ -1351,11 +371,7 @@ fn generate_ml( extra_types: &[], })), &[ "TraitImpl", - ]), - (GenerationKind::TypeDecl(None), &[ - "CliOpts", "GExprBody", - "DeclarationGroup", ]), ]), }, @@ -1388,23 +404,31 @@ fn generate_ml( ]), }, GenerateCodeFor { - template: template_dir.join("GAstOfJson.ml"), - target: output_dir.join("Generated_GAstOfJson.ml"), - markers: vec![(GenerationKind::OfJson, gast_types)], - }, - GenerateCodeFor { - template: template_dir.join("LlbcOfJson.ml"), - target: output_dir.join("Generated_LlbcOfJson.ml"), - markers: vec![(GenerationKind::OfJson, llbc_types)], + template: template_dir.join("FullAst.ml"), + target: output_dir.join("Generated_FullAst.ml"), + markers: markers_from_children(&ctx, &[ + (GenerationKind::TypeDecl(None), &[ + "FunDecl", + "Body", + "CliOpts", + "DeclarationGroup", + "TranslatedCrate", + ]), + ]), }, GenerateCodeFor { - template: template_dir.join("UllbcOfJson.ml"), - target: output_dir.join("Generated_UllbcOfJson.ml"), - markers: vec![(GenerationKind::OfJson, ullbc_types)], + template: template_dir.join("OfJson.ml"), + target: output_dir.join("Generated_OfJson.ml"), + markers: vec![ + (GenerationKind::OfJson, gast_types), + (GenerationKind::OfJson, ullbc_types), + (GenerationKind::OfJson, llbc_types), + (GenerationKind::OfJson, full_ast_types), + ], }, ]; for file in generate_code_for { - file.generate(&ctx)?; + file.generate(&mut ctx)?; } Ok(()) } diff --git a/charon/src/bin/generate-ml/of_json.rs b/charon/src/bin/generate-ml/of_json.rs new file mode 100644 index 000000000..f12b00107 --- /dev/null +++ b/charon/src/bin/generate-ml/of_json.rs @@ -0,0 +1,386 @@ +use std::collections::HashMap; + +use charon_lib::ast::*; +use indoc::indoc; +use itertools::Itertools; + +use crate::GenerateCtx; +use crate::util::*; + +const MANUAL_IMPLS: &[(&str, &str)] = &[ + // Hand-written because we interpret it as a list. + ( + "charon_lib::ids::index_vec::IndexVec", + "list_of_json arg1_of_json ctx json", + ), + // Hand-written because we interpret it as a list. + ( + "charon_lib::ids::index_map::IndexMap", + indoc!( + r#" + let* list = list_of_json (option_of_json arg1_of_json) ctx json in + Ok (List.filter_map (fun x -> x) list) + "# + ), + ), + // Hand-written because we turn it into a list of pairs. + ( + "indexmap::map::IndexMap", + "list_of_json (key_value_pair_of_json arg0_of_json arg1_of_json) ctx json", + ), + // Hand-written because we replace the `FileId` with the corresponding file name. + ( + "FileId", + indoc!( + r#" + let* file_id = FileId.id_of_json ctx json in + let file = FileTbl.find ctx.id_to_file_map file_id in + Ok file + "#, + ), + ), + ( + "File", + indoc!( + r#" + (match json with + | `Assoc + [ ("id", id); ("name", name); ("crate_name", crate_name); ("contents", contents) ] + -> + let* id = FileId.id_of_json ctx id in + let* name = file_name_of_json ctx name in + let* crate_name = string_of_json ctx crate_name in + let* contents = option_of_json string_of_json ctx contents in + let file: file = { name; crate_name; contents } in + FileTbl.add ctx.id_to_file_map id file; + Ok file + | _ -> Error "") + "# + ), + ), + ( + "HashConsed", + r#"Error "use `hash_consed_val_of_json` instead""#, + ), // Not actually used + ( + "Ty", + "hash_consed_val_of_json ctx.ty_hashcons_map ty_kind_of_json ctx json", + ), + ( + "TraitRef", + "hash_consed_val_of_json ctx.tref_hashcons_map trait_ref_contents_of_json ctx json", + ), +]; + +impl<'a> GenerateCtx<'a> { + fn build_function(&self, decl: &TypeDecl, branches: &str) -> String { + let ty = TyKind::Adt(TypeDeclRef { + id: TypeId::Adt(decl.def_id), + generics: decl.generics.identity_args().into(), + }) + .into_ty(); + let (ty_name, _) = self.type_to_ocaml_ident_raw(decl); + let ty = self.type_to_ocaml_name(&ty); + let signature = if decl.generics.types.is_empty() { + format!("{ty_name}_of_json (ctx : of_json_ctx) (js : json) : ({ty}, string) result =") + } else { + let types = &decl.generics.types; + let gen_vars_space = types + .iter() + .enumerate() + .map(|(i, _)| format!("'a{i}")) + .join(" "); + + let mut args = Vec::new(); + let mut ty_args = Vec::new(); + for (i, _) in types.iter().enumerate() { + args.push(format!("arg{i}_of_json")); + ty_args.push(format!("(of_json_ctx -> json -> ('a{i}, string) result)")); + } + args.push("ctx".to_string()); + ty_args.push("of_json_ctx".to_string()); + args.push("js".to_string()); + ty_args.push("json".to_string()); + + let ty_args = ty_args.into_iter().join(" -> "); + let args = args.into_iter().join(" "); + let fun_ty = format!("{gen_vars_space}. {ty_args} -> ({ty}, string) result"); + format!("{ty_name}_of_json : {fun_ty} = fun {args} ->") + }; + format!( + r#" + and {signature} + combine_error_msgs js __FUNCTION__ + (match js with{branches} | _ -> Error "") + "# + ) + } + + /// Converts a type to the appropriate `*_of_json` call. In case of generics, this combines several + /// functions, e.g. `list_of_json bool_of_json`. + fn type_to_ocaml_call(&self, ty: &Ty) -> String { + match ty.kind() { + TyKind::Literal(LiteralTy::Bool) => "bool_of_json".to_string(), + TyKind::Literal(LiteralTy::Char) => "char_of_json".to_string(), + TyKind::Literal(LiteralTy::Int(int_ty)) => match int_ty { + // Even though OCaml ints are only 63 bits, only scalars with their 128 bits should be able to become too large + IntTy::I128 => "big_int_of_json".to_string(), + _ => "int_of_json".to_string(), + }, + TyKind::Literal(LiteralTy::UInt(uint_ty)) => match uint_ty { + // Even though OCaml ints are only 63 bits, only scalars with their 128 bits should be able to become too large + UIntTy::U128 => "big_int_of_json".to_string(), + _ => "int_of_json".to_string(), + }, + TyKind::Literal(LiteralTy::Float(_)) => "float_of_json".to_string(), + TyKind::Adt(tref) => { + let mut expr = Vec::new(); + for ty in &tref.generics.types { + expr.push(self.type_to_ocaml_call(ty)) + } + match tref.id { + TypeId::Adt(id) => { + let mut first = if let Some(tdecl) = self.crate_data.type_decls.get(id) { + let (name, module) = self.type_to_ocaml_ident_raw(tdecl); + match module { + Some((_, short)) if !self.current_ids.contains(&id) => { + format!("{short}.{name}") + } + _ => name, + } + } else { + format!("missing_type_{id}") + }; + if first == "vec" { + first = "list".to_string(); + } + if first == "ustr" { + first = "string".to_string(); + } + if first == "index_map" { + // That's the `indexmap::IndexMap` case. Pass something dummy for the + // `RandomState` parameter. + expr[2] = "int_of_json".to_string(); + } + + if first == "indexed_map" && self.use_opt_index_map() { + first = format!("opt_{first}"); + } + + expr.insert(0, first + "_of_json"); + } + TypeId::Builtin(BuiltinTy::Box) => expr.insert(0, "box_of_json".to_owned()), + TypeId::Tuple => { + let name = match tref.generics.types.len() { + 2 => "pair_of_json".to_string(), + 3 => "triple_of_json".to_string(), + len => format!("tuple_{len}_of_json"), + }; + expr.insert(0, name); + } + _ => unimplemented!("{ty:?}"), + } + expr.into_iter().map(|f| format!("({f})")).join(" ") + } + TyKind::TypeVar(DeBruijnVar::Free(id)) => format!("arg{id}_of_json"), + _ => unimplemented!("{ty:?}"), + } + } + + fn convert_vars<'b>(&self, fields: impl IntoIterator) -> String { + fields + .into_iter() + .filter(|f| !f.is_opaque()) + .map(|f| { + let name = make_ocaml_ident(f.name.as_deref().unwrap()); + let rename = make_ocaml_ident(f.renamed_name().unwrap()); + let convert = self.type_to_ocaml_call(&f.ty); + format!("let* {rename} = {convert} ctx {name} in") + }) + .join("\n") + } + + fn build_branch<'b>( + &self, + pat: &str, + fields: impl IntoIterator, + construct: &str, + ) -> String { + let convert = self.convert_vars(fields); + format!("| {pat} -> {convert} Ok ({construct})") + } + + fn type_decl_to_json_deserializer( + &self, + manual_impls: &HashMap, + decl: &TypeDecl, + ) -> String { + let return_ty = self.type_to_ocaml_ident(decl); + let return_ty = if decl.generics.types.is_empty() { + return_ty + } else { + format!("_ {return_ty}") + }; + + let branches = match &decl.kind { + _ if let Some(def) = manual_impls.get(&decl.def_id) => { + format!("| json -> {def}") + } + TypeDeclKind::Struct(fields) if fields.is_empty() => { + self.build_branch("`Null", fields, "()") + } + TypeDeclKind::Struct(fields) + if fields.len() == 1 + && fields[0].name.as_ref().is_some_and(|name| name == "_raw") => + { + // These are the special strongly-typed integers. + let short_name = decl.item_meta.name.short_str(); + format!("| x -> {short_name}.id_of_json ctx x") + } + TypeDeclKind::Struct(fields) + if fields.len() == 1 + && (fields[0].name.is_none() + || decl + .item_meta + .attr_info + .attributes + .iter() + .filter_map(|a| a.as_unknown()) + .any(|a| a.to_string() == "serde(transparent)")) => + { + let ty = &fields[0].ty; + let call = self.type_to_ocaml_call(ty); + format!("| x -> {call} ctx x") + } + TypeDeclKind::Alias(ty) => { + let call = self.type_to_ocaml_call(ty); + format!("| x -> {call} ctx x") + } + TypeDeclKind::Struct(fields) if fields.iter().all(|f| f.name.is_none()) => { + let mut fields = fields.clone(); + for (i, f) in fields.iter_mut().enumerate() { + f.name = Some(format!("x{i}")); + } + let pat: String = fields + .iter() + .map(|f| f.name.as_deref().unwrap()) + .map(make_ocaml_ident) + .join(";"); + let pat = format!("`List [ {pat} ]"); + let construct = fields + .iter() + .map(|f| f.renamed_name().unwrap()) + .map(make_ocaml_ident) + .join(", "); + let construct = format!("( {construct} )"); + self.build_branch(&pat, &fields, &construct) + } + TypeDeclKind::Struct(fields) => { + let fields = fields + .iter() + .filter(|field| { + !field + .attr_info + .attributes + .iter() + .filter_map(|a| a.as_unknown()) + .any(|a| a.to_string() == "serde(skip)") + }) + .collect_vec(); + let pat: String = fields + .iter() + .map(|f| { + let name = f.name.as_ref().unwrap(); + let var = if f.is_opaque() { + "_" + } else { + &make_ocaml_ident(name) + }; + format!("(\"{name}\", {var});") + }) + .join("\n"); + let pat = format!("`Assoc [ {pat} ]"); + let construct = fields + .iter() + .filter(|f| !f.is_opaque()) + .map(|f| f.renamed_name().unwrap()) + .map(make_ocaml_ident) + .join("; "); + let construct = format!("({{ {construct} }} : {return_ty})"); + self.build_branch(&pat, fields, &construct) + } + TypeDeclKind::Enum(variants) => { + variants + .iter() + .filter(|v| !v.is_opaque()) + .map(|variant| { + let name = &variant.name; + let rename = variant.renamed_name(); + if variant.fields.is_empty() { + // Unit variant + let pat = format!("`String \"{name}\""); + self.build_branch(&pat, &variant.fields, rename) + } else { + let mut fields = variant.fields.clone(); + let inner_pat = if fields.iter().all(|f| f.name.is_none()) { + // Tuple variant + if variant.fields.len() == 1 { + let var = make_ocaml_ident(&variant.name); + fields[0].name = Some(var.clone()); + var + } else { + for (i, f) in fields.iter_mut().enumerate() { + f.name = Some(format!("x_{i}")); + } + let pat = + fields.iter().map(|f| f.name.as_ref().unwrap()).join("; "); + format!("`List [ {pat} ]") + } + } else { + // Struct variant + let pat = fields + .iter() + .map(|f| { + let name = f.name.as_ref().unwrap(); + let var = if f.is_opaque() { + "_" + } else { + &make_ocaml_ident(name) + }; + format!("(\"{name}\", {var});") + }) + .join(" "); + format!("`Assoc [ {pat} ]") + }; + let pat = format!("`Assoc [ (\"{name}\", {inner_pat}) ]"); + let construct_fields = fields + .iter() + .map(|f| f.name.as_ref().unwrap()) + .map(|n| make_ocaml_ident(n)) + .join(", "); + let construct = format!("{rename} ({construct_fields})"); + self.build_branch(&pat, &fields, &construct) + } + }) + .join("\n") + } + TypeDeclKind::Union(..) => todo!(), + TypeDeclKind::Opaque => todo!(), + TypeDeclKind::Error(_) => todo!(), + }; + self.build_function(decl, &branches) + } + + pub fn type_decls_to_json(&mut self, tys: Vec<&TypeDecl>) -> String { + let manual_impls = self.names_to_type_id_map(MANUAL_IMPLS); + let fns = tys + .iter() + .map(|ty| { + self.with_item(ty, |ctx| { + ctx.type_decl_to_json_deserializer(&manual_impls, ty) + }) + }) + .format("\n"); + format!("let rec ___ = ()\n{fns}") + } +} diff --git a/charon/src/bin/generate-ml/templates/Expressions.ml b/charon/src/bin/generate-ml/templates/Expressions.ml index 26b37f394..76d7a1fb1 100644 --- a/charon/src/bin/generate-ml/templates/Expressions.ml +++ b/charon/src/bin/generate-ml/templates/Expressions.ml @@ -8,8 +8,8 @@ code-generation code is in `charon/src/bin/generate-ml`. *) open Identifiers -open Types -open Values +open Generated_Types +open Generated_Values module LocalId = IdGen () module GlobalDeclId = Types.GlobalDeclId module FunDeclId = Types.FunDeclId diff --git a/charon/src/bin/generate-ml/templates/FullAst.ml b/charon/src/bin/generate-ml/templates/FullAst.ml new file mode 100644 index 000000000..547391792 --- /dev/null +++ b/charon/src/bin/generate-ml/templates/FullAst.ml @@ -0,0 +1,21 @@ +(** WARNING: this file is partially auto-generated. Do not edit `FullAst.ml` + by hand. Edit `templates/FullAst.ml` instead, or improve the code + generation tool so avoid the need for hand-writing things. + + `templates/FullAst.ml` contains the manual definitions and some `(* + __REPLACEn__ *)` comments. These comments are replaced by auto-generated + definitions by running `make generate-ml` in the crate root. The + code-generation code is in `charon/src/bin/generate-ml`. + *) + + open Generated_GAst + open Generated_UllbcAst + open Generated_LlbcAst + open Generated_Types + open Generated_Values + open Generated_Expressions + open Generated_Meta + open Identifiers + + (* __REPLACE0__ *) + [@@deriving show] diff --git a/charon/src/bin/generate-ml/templates/GAst.ml b/charon/src/bin/generate-ml/templates/GAst.ml index c83bf21d1..6eaaedc42 100644 --- a/charon/src/bin/generate-ml/templates/GAst.ml +++ b/charon/src/bin/generate-ml/templates/GAst.ml @@ -8,9 +8,9 @@ code-generation code is in `charon/src/bin/generate-ml`. *) -open Types -open Meta -open Expressions +open Generated_Types +open Generated_Meta +open Generated_Expressions module FunDeclId = Expressions.FunDeclId module GlobalDeclId = Expressions.GlobalDeclId @@ -31,6 +31,3 @@ type fun_decl_id = Types.fun_decl_id [@@deriving show, ord] (* __REPLACE2__ *) (* __REPLACE3__ *) - -(* __REPLACE4__ *) -[@@deriving show] diff --git a/charon/src/bin/generate-ml/templates/LlbcAst.ml b/charon/src/bin/generate-ml/templates/LlbcAst.ml index 36aa3d703..d917ab9e4 100644 --- a/charon/src/bin/generate-ml/templates/LlbcAst.ml +++ b/charon/src/bin/generate-ml/templates/LlbcAst.ml @@ -1,8 +1,8 @@ -open GAst -open Types -open Values -open Expressions -open Meta +open Generated_GAst +open Generated_Types +open Generated_Values +open Generated_Expressions +open Generated_Meta open Identifiers module StatementId = IdGen () diff --git a/charon/src/bin/generate-ml/templates/LlbcOfJson.ml b/charon/src/bin/generate-ml/templates/LlbcOfJson.ml deleted file mode 100644 index 5fbb4a7b4..000000000 --- a/charon/src/bin/generate-ml/templates/LlbcOfJson.ml +++ /dev/null @@ -1,6 +0,0 @@ -open OfJsonBasic -open Types -open LlbcAst -open GAstOfJson - -(* __REPLACE0__ *) diff --git a/charon/src/bin/generate-ml/templates/GAstOfJson.ml b/charon/src/bin/generate-ml/templates/OfJson.ml similarity index 63% rename from charon/src/bin/generate-ml/templates/GAstOfJson.ml rename to charon/src/bin/generate-ml/templates/OfJson.ml index e57168c55..07a3873eb 100644 --- a/charon/src/bin/generate-ml/templates/GAstOfJson.ml +++ b/charon/src/bin/generate-ml/templates/OfJson.ml @@ -1,8 +1,8 @@ -(** WARNING: this file is partially auto-generated. Do not edit `GAstOfJson.ml` - by hand. Edit `GAstOfJson.template.ml` instead, or improve the code +(** WARNING: this file is partially auto-generated. Do not edit `OfJson.ml` + by hand. Edit `templates/OfJson.ml` instead, or improve the code generation tool so avoid the need for hand-writing things. - `GAstOfJson.template.ml` contains the manual definitions and some `(* + `templates/OfJson.ml` contains the manual definitions and some `(* __REPLACEn__ *)` comments. These comments are replaced by auto-generated definitions by running `make generate-ml` in the crate root. The code-generation code is in `charon/src/bin/generate-ml`. @@ -11,29 +11,35 @@ open Yojson.Basic open OfJsonBasic open Identifiers -open Meta -open Values -open Types +open Generated_Meta +open Generated_Values +open Generated_Types +open Generated_Expressions +open Generated_GAst +open Generated_FullAst open Scalars -open Expressions -open GAst module FileId = IdGen () module HashConsId = IdGen () (** The default logger *) let log = Logging.llbc_of_json_logger +module FileTbl = Hashtbl.Make (struct + type t = FileId.id + + let equal = FileId.equal_id + let hash = Hashtbl.hash +end) -type id_to_file_map = file FileId.Map.t type of_json_ctx = { - id_to_file_map : id_to_file_map; - ty_hashcons_map: (ty HashConsId.Map.t) ref; - tref_hashcons_map: (trait_ref HashConsId.Map.t) ref; + id_to_file_map : file FileTbl.t; + ty_hashcons_map : ty HashConsId.Map.t ref; + tref_hashcons_map : trait_ref HashConsId.Map.t ref; } let empty_of_json_ctx : of_json_ctx = { - id_to_file_map = FileId.Map.empty; + id_to_file_map = FileTbl.create 8; ty_hashcons_map = ref HashConsId.Map.empty; tref_hashcons_map = ref HashConsId.Map.empty; } @@ -69,4 +75,29 @@ let big_int_of_json _ (js : json) : (big_int, string) result = | `String is -> Ok (Z.of_string is) | _ -> Error "") +let opt_indexed_map_of_json : + 'a0 'a1. + (of_json_ctx -> json -> ('a0, string) result) -> + (of_json_ctx -> json -> ('a1, string) result) -> + of_json_ctx -> + json -> + ( 'a1 option list, string) result = + fun arg0_of_json arg1_of_json ctx js -> + list_of_json (option_of_json arg1_of_json) ctx js + + (* __REPLACE0__ *) + +module Ullbc = struct + open UllbcAst + + (* __REPLACE1__ *) +end + +module Llbc = struct + open LlbcAst + + (* __REPLACE2__ *) +end + +(* __REPLACE3__ *) diff --git a/charon/src/bin/generate-ml/templates/Types.ml b/charon/src/bin/generate-ml/templates/Types.ml index 69f9cf8fa..0b6e1b88e 100644 --- a/charon/src/bin/generate-ml/templates/Types.ml +++ b/charon/src/bin/generate-ml/templates/Types.ml @@ -10,8 +10,8 @@ *) open Identifiers -open Meta -open Values +open Generated_Meta +open Generated_Values module TypeVarId = IdGen () module TypeDeclId = IdGen () @@ -38,6 +38,7 @@ type literal_type = Values.literal_type [@@deriving show, ord, eq] declare it within a visitor group. *) type trait_type_constraint_id = TraitTypeConstraintId.id [@@deriving show, ord, eq] + (* __REPLACE0__ *) (* __REPLACE1__ *) diff --git a/charon/src/bin/generate-ml/templates/UllbcAst.ml b/charon/src/bin/generate-ml/templates/UllbcAst.ml index 2968db44f..f52903235 100644 --- a/charon/src/bin/generate-ml/templates/UllbcAst.ml +++ b/charon/src/bin/generate-ml/templates/UllbcAst.ml @@ -1,9 +1,9 @@ -open Types -open Values -open Expressions -open Meta +open Generated_Types +open Generated_Values +open Generated_Expressions +open Generated_Meta +open Generated_GAst open Identifiers -open GAst module BlockId = IdGen () diff --git a/charon/src/bin/generate-ml/templates/UllbcOfJson.ml b/charon/src/bin/generate-ml/templates/UllbcOfJson.ml deleted file mode 100644 index 4dedfd7eb..000000000 --- a/charon/src/bin/generate-ml/templates/UllbcOfJson.ml +++ /dev/null @@ -1,7 +0,0 @@ -open OfJsonBasic -open Types -open Expressions -open UllbcAst -open GAstOfJson - -(* __REPLACE0__ *) diff --git a/charon/src/bin/generate-ml/to_ocaml_ty.rs b/charon/src/bin/generate-ml/to_ocaml_ty.rs new file mode 100644 index 000000000..d8cee9729 --- /dev/null +++ b/charon/src/bin/generate-ml/to_ocaml_ty.rs @@ -0,0 +1,450 @@ +use crate::GenerateCtx; +use charon_lib::ast::*; +use itertools::Itertools; +use std::collections::HashMap; +use std::collections::HashSet; +use std::fmt::Write; + +const MANUAL_IMPLS: &[(&str, &str)] = &[ + // Hand-written because we replace the `FileId` with the corresponding file. + ("FileId", "file"), + ( + "HashConsed", + "'a0 (* Not actually hash-consed on the OCaml side *)", + ), +]; + +#[derive(Clone, Copy)] +pub struct DeriveVisitors { + pub name: &'static str, + pub ancestors: &'static [&'static str], + pub reduce: bool, + pub extra_types: &'static [&'static str], +} + +impl<'a> GenerateCtx<'a> { + fn extract_doc_comments(&self, attr_info: &AttrInfo) -> String { + attr_info + .attributes + .iter() + .filter_map(|a| a.as_doc_comment()) + .join("\n") + } + + /// Make a doc comment that contains the given string, indenting it if necessary. + fn build_doc_comment(&self, comment: String, indent_level: usize) -> String { + #[derive(Default)] + struct Exchanger { + is_in_open_escaped_block: bool, + is_in_open_inline_escape: bool, + } + impl Exchanger { + pub fn exchange_escape_delimiters(&mut self, line: &str) -> String { + if line.contains("```") { + // Handle multi-line escaped blocks. + let (leading, mut rest) = line.split_once("```").unwrap(); + + // Strip all (hard-coded) possible ways to open the block. + rest = if rest.starts_with("text") { + rest.strip_prefix("text").unwrap() + } else if rest.starts_with("rust,ignore") { + rest.strip_prefix("rust,ignore").unwrap() + } else { + rest + }; + let mut result = leading.to_owned(); + if self.is_in_open_escaped_block { + result.push_str("]}"); + self.is_in_open_escaped_block = false; + } else { + result.push_str("{@rust["); + self.is_in_open_escaped_block = true; + } + result.push_str(rest); + result + } else if line.contains('`') { + // Handle inline escaped strings. These can occur in multiple lines, so we track them globally. + let mut parts = line.split('`'); + // Skip after first part (we only need to add escapes after that). + let mut result = parts.next().unwrap().to_owned(); + for part in parts { + if self.is_in_open_inline_escape { + result.push(']'); + result.push_str(part); + self.is_in_open_inline_escape = false; + } else { + result.push('['); + result.push_str(part); + self.is_in_open_inline_escape = true; + } + } + result + } else { + line.to_owned() + } + } + } + + if comment.is_empty() { + return comment; + } + let is_multiline = comment.contains("\n"); + if !is_multiline { + let fixed_comment = Exchanger::default().exchange_escape_delimiters(&comment); + format!("(**{fixed_comment} *)") + } else { + let indent = " ".repeat(indent_level); + let mut exchanger = Exchanger::default(); + let comment = comment + .lines() + .enumerate() + .map(|(i, line)| { + // Remove one leading space if there is one (there usually is because we write `/// + // comment` and not `///comment`). + let line = line.strip_prefix(" ").unwrap_or(line); + let fixed_line = exchanger.exchange_escape_delimiters(line); + + // The first line follows the `(**` marker, it does not need to be indented. + // Neither do empty lines. + if i == 0 || fixed_line.is_empty() { + fixed_line + } else { + format!("{indent} {fixed_line}") + } + }) + .join("\n"); + format!("(** {comment}\n{indent} *)") + } + } + + fn build_type(&self, decl: &TypeDecl, co_rec: bool, body: &str) -> String { + let (ty_name, _) = self.type_to_ocaml_ident_raw(decl); + let generics = decl + .generics + .types + .iter() + .enumerate() + .map(|(i, _)| format!("'a{i}")) + .collect_vec(); + let generics = match generics.as_slice() { + [] => String::new(), + [ty] => ty.clone(), + generics => format!("({})", generics.iter().join(",")), + }; + let comment = self.extract_doc_comments(&decl.item_meta.attr_info); + let comment = self.build_doc_comment(comment, 0); + let keyword = if co_rec { "and" } else { "type" }; + format!("\n{comment} {keyword} {generics} {ty_name} = {body}") + } + + /// Generate an ocaml type declaration that mirrors `decl`. + /// + /// `co_rec` indicates whether this definition is co-recursive with the ones that come before (i.e. + /// should be declared with `and` instead of `type`). + fn type_decl_to_ocaml_decl( + &self, + opaque_for_visitor: &HashSet, + manual_impls: &HashMap, + decl: &TypeDecl, + co_rec: bool, + ) -> String { + let opaque = if opaque_for_visitor.contains(&decl.def_id) { + "[@visitors.opaque]" + } else { + "" + }; + let body = match &decl.kind { + _ if let Some(def) = manual_impls.get(&decl.def_id) => def.clone(), + TypeDeclKind::Alias(ty) => { + let ty = self.type_to_ocaml_name(ty); + format!("{ty} {opaque}") + } + TypeDeclKind::Struct(fields) if fields.is_empty() => "unit".to_string(), + TypeDeclKind::Struct(fields) + if fields.len() == 1 + && fields[0].name.as_ref().is_some_and(|name| name == "_raw") => + { + // These are the special strongly-typed integers. + let short_name = decl.item_meta.name.short_str(); + format!("{short_name}.id [@visitors.opaque]") + } + TypeDeclKind::Struct(fields) + if fields.len() == 1 + && (fields[0].name.is_none() + || decl + .item_meta + .attr_info + .attributes + .iter() + .filter_map(|a| a.as_unknown()) + .any(|a| a.to_string() == "serde(transparent)")) => + { + let ty = self.type_to_ocaml_name(&fields[0].ty); + format!("{ty} {opaque}") + } + TypeDeclKind::Struct(fields) if fields.iter().all(|f| f.name.is_none()) => fields + .iter() + .filter(|f| !f.is_opaque()) + .map(|f| { + let ty = self.type_to_ocaml_name(&f.ty); + format!("{ty} {opaque}") + }) + .join("*"), + TypeDeclKind::Struct(fields) => { + let fields = fields + .iter() + .filter(|f| !f.is_opaque()) + .map(|f| { + let name = f.renamed_name().unwrap(); + let ty = self.type_to_ocaml_name(&f.ty); + let comment = self.extract_doc_comments(&f.attr_info); + let comment = self.build_doc_comment(comment, 2); + format!("{name} : {ty} {opaque} {comment}") + }) + .join(";"); + format!("{{ {fields} }}") + } + TypeDeclKind::Enum(variants) => { + variants + .iter() + .filter(|v| !v.is_opaque()) + .map(|variant| { + let mut attr_info = variant.attr_info.clone(); + let rename = variant.renamed_name(); + let ty = if variant.fields.is_empty() { + // Unit variant + String::new() + } else { + if variant.fields.iter().all(|f| f.name.is_some()) { + let fields = variant + .fields + .iter() + .map(|f| { + let comment = self.extract_doc_comments(&f.attr_info); + let description = if comment.is_empty() { + comment + } else { + format!(": {comment}") + }; + format!("\n - [{}]{description}", f.name.as_ref().unwrap()) + }) + .join(""); + let field_descriptions = format!("\n Fields:{fields}"); + // Add a constructed doc-comment + attr_info + .attributes + .push(Attribute::DocComment(field_descriptions)); + } + let fields = variant + .fields + .iter() + .map(|f| { + let ty = self.type_to_ocaml_name(&f.ty); + format!("{ty} {opaque}") + }) + .join("*"); + format!(" of {fields}") + }; + let comment = self.extract_doc_comments(&attr_info); + let comment = self.build_doc_comment(comment, 3); + format!("\n\n | {rename}{ty} {comment}") + }) + .join("") + } + TypeDeclKind::Union(..) => todo!(), + TypeDeclKind::Opaque => todo!(), + TypeDeclKind::Error(_) => todo!(), + }; + self.build_type(decl, co_rec, &body) + } + + fn generate_visitor_bases( + &self, + name: &str, + inherits: &[&str], + reduce: bool, + ty_names: &[String], + ) -> String { + let mut out = String::new(); + let make_inherit = |variety| { + if !inherits.is_empty() { + inherits + .iter() + .map(|ancestor| { + if let [module, name] = ancestor.split(".").collect_vec().as_slice() { + format!("inherit [_] {module}.{variety}_{name}") + } else { + format!("inherit [_] {variety}_{ancestor}") + } + }) + .join("\n") + } else { + format!("inherit [_] VisitorsRuntime.{variety}") + } + }; + + let iter_methods = ty_names + .iter() + .map(|ty| format!("method visit_{ty} : 'env -> {ty} -> unit = fun _ _ -> ()")) + .format("\n"); + let _ = write!( + &mut out, + " + class ['self] iter_{name} = + object (self : 'self) + {} + {iter_methods} + end + ", + make_inherit("iter") + ); + + let map_methods = ty_names + .iter() + .map(|ty| format!("method visit_{ty} : 'env -> {ty} -> {ty} = fun _ x -> x")) + .format("\n"); + let _ = write!( + &mut out, + " + class ['self] map_{name} = + object (self : 'self) + {} + {map_methods} + end + ", + make_inherit("map") + ); + + if reduce { + let reduce_methods = ty_names + .iter() + .map(|ty| format!("method visit_{ty} : 'env -> {ty} -> 'a = fun _ _ -> self#zero")) + .format("\n"); + let _ = write!( + &mut out, + " + class virtual ['self] reduce_{name} = + object (self : 'self) + {} + {reduce_methods} + end + ", + make_inherit("reduce") + ); + + let mapreduce_methods = ty_names + .iter() + .map(|ty| { + format!( + "method visit_{ty} : 'env -> {ty} -> {ty} * 'a = fun _ x -> (x, self#zero)" + ) + }) + .format("\n"); + let _ = write!( + &mut out, + " + class virtual ['self] mapreduce_{name} = + object (self : 'self) + {} + {mapreduce_methods} + end + ", + make_inherit("mapreduce") + ); + } + + out + } + + fn add_visitors_to_decls(&self, visitors: &DeriveVisitors, mut decls: String) -> String { + let &DeriveVisitors { + name, + mut ancestors, + reduce, + extra_types, + } = visitors; + let varieties: &[_] = if reduce { + &["iter", "map", "reduce", "mapreduce"] + } else { + &["iter", "map"] + }; + let intermediate_visitor_name; + let intermediate_visitor_name_slice; + if !extra_types.is_empty() { + intermediate_visitor_name = format!("{name}_base"); + let intermediate_visitor = self.generate_visitor_bases( + &intermediate_visitor_name, + ancestors, + reduce, + extra_types + .iter() + .map(|s| s.to_string()) + .collect_vec() + .as_slice(), + ); + intermediate_visitor_name_slice = [intermediate_visitor_name.as_str()]; + ancestors = &intermediate_visitor_name_slice; + decls = + format!("(* Ancestors for the {name} visitors *){intermediate_visitor}\n{decls}"); + } + let visitors = varieties + .iter() + .map(|variety| { + let nude = if !ancestors.is_empty() { + "nude = true (* Don't inherit VisitorsRuntime *);".to_string() + } else { + String::new() + }; + let ancestors = format!( + "ancestors = [ {} ];", + ancestors + .iter() + .map(|a| format!("\"{variety}_{a}\"")) + .join(";") + ); + format!( + r#" + visitors {{ + name = "{variety}_{name}"; + monomorphic = ["env"]; + variety = "{variety}"; + {ancestors} + {nude} + }} + "# + ) + }) + .format(", "); + write!(&mut decls, "\n[@@deriving show, eq, ord, {visitors}]").unwrap(); + decls + } + + pub fn type_decls_to_ocaml( + &mut self, + visitors: &Option, + tys: Vec<&TypeDecl>, + ) -> String { + // Types that we don't want visitors to go into. + let opaque_for_visitors = self.names_to_type_id_set(&["Name"]); + let manual_impls = self.names_to_type_id_map(MANUAL_IMPLS); + let decls = tys + .into_iter() + .enumerate() + .map(|(i, ty)| { + let co_recursive = i != 0; + self.with_item(ty, |ctx| { + ctx.type_decl_to_ocaml_decl( + &opaque_for_visitors, + &manual_impls, + ty, + co_recursive, + ) + }) + }) + .join("\n"); + match visitors { + Some(visitors) => self.add_visitors_to_decls(visitors, decls), + None => decls, + } + } +} diff --git a/charon/src/bin/generate-ml/util.rs b/charon/src/bin/generate-ml/util.rs new file mode 100644 index 000000000..d37c977b8 --- /dev/null +++ b/charon/src/bin/generate-ml/util.rs @@ -0,0 +1,223 @@ +use charon_lib::ast::*; +use convert_case::{Case, Casing}; +use itertools::Itertools; +use std::collections::{HashMap, HashSet}; + +use crate::GenerateCtx; + +/// `Name` is a complex datastructure; to inspect it we serialize it a little bit. +pub fn repr_name(n: &Name) -> String { + n.name + .iter() + .map(|path_elem| match path_elem { + PathElem::Ident(i, _) => i.clone(), + PathElem::Impl(..) => "".to_string(), + PathElem::Instantiated(..) => "".to_string(), + PathElem::Target(target) => target.clone(), + }) + .join("::") +} + +pub fn make_ocaml_ident(name: &str) -> String { + let mut name = name.to_case(Case::Snake); + if matches!( + &*name, + "assert" + | "bool" + | "char" + | "end" + | "float" + | "fun" + | "function" + | "include" + | "let" + | "method" + | "open" + | "rec" + | "struct" + | "to" + | "type" + | "virtual" + ) { + name += "_"; + } + name +} + +impl<'a> GenerateCtx<'a> { + pub fn id_from_name(&self, name: &str) -> TypeDeclId { + self.name_to_type + .get(name) + .unwrap_or_else(|| panic!("Name not found: `{name}`")) + .def_id + } + + /// List the (recursive) children of this type. + pub fn children_of(&self, name: &str) -> HashSet { + let start_id = self.id_from_name(name); + self.children_of_inner(vec![start_id], |_| true) + } + + /// List the (recursive) children of these types. + pub fn children_of_many(&self, names: &[&str]) -> HashSet { + self.children_of_inner( + names.iter().map(|name| self.id_from_name(name)).collect(), + |_| true, + ) + } + + pub fn children_of_inner( + &self, + ty: Vec, + explore: impl Fn(TypeDeclId) -> bool, + ) -> HashSet { + let mut children = HashSet::new(); + let mut stack = ty.to_vec(); + while let Some(id) = stack.pop() { + if !children.contains(&id) + && explore(id) + && self + .crate_data + .type_decls + .get(id) + .is_some_and(|decl| decl.item_meta.is_local) + { + children.insert(id); + if let Some(contained) = self.type_tree.get(&id) { + stack.extend(contained); + } + } + } + children + } + + /// Returns the OCaml identifier corresponding to this type, + /// and the generated module name + short module name associated to it if + /// they exist. + pub fn type_to_ocaml_ident_raw(&self, td: &TypeDecl) -> (String, Option<(String, String)>) { + let name = td + .item_meta + .attr_info + .rename + .as_ref() + .unwrap_or(td.item_meta.name.short_str()); + let module = self.ambiguous_types.get(&td.def_id); + (make_ocaml_ident(name), module.cloned()) + } + + pub fn type_to_ocaml_ident(&self, td: &TypeDecl) -> String { + let (name, module) = self.type_to_ocaml_ident_raw(td); + match module { + Some((module, _)) if self.current_module.as_ref().is_none_or(|m| m != &module) => { + format!("{module}.{name}") + } + _ => name, + } + } + + /// Converts a type to the appropriate ocaml name. In case of generics, this provides appropriate + /// parameters. + pub fn type_to_ocaml_name(&self, ty: &Ty) -> String { + match ty.kind() { + TyKind::Literal(LiteralTy::Bool) => "bool".to_string(), + TyKind::Literal(LiteralTy::Char) => "(Uchar.t [@visitors.opaque])".to_string(), + TyKind::Literal(LiteralTy::Int(int_ty)) => match int_ty { + // Even though OCaml ints are only 63 bits, only scalars with their 128 bits should be able to become too large + IntTy::I128 => "big_int".to_string(), + _ => "int".to_string(), + }, + TyKind::Literal(LiteralTy::UInt(uint_ty)) => match uint_ty { + // Even though OCaml ints are only 63 bits, only scalars with their 128 bits should be able to become too large + UIntTy::U128 => "big_int".to_string(), + _ => "int".to_string(), + }, + TyKind::Literal(LiteralTy::Float(_)) => "float_of_json".to_string(), + TyKind::Adt(tref) => { + let mut args = tref + .generics + .types + .iter() + .map(|ty| self.type_to_ocaml_name(ty)) + .map(|name| { + if !name.chars().all(|c| c.is_alphanumeric()) { + format!("({name})") + } else { + name + } + }) + .collect_vec(); + match tref.id { + TypeId::Adt(id) => { + let mut base_ty = if let Some(tdecl) = self.crate_data.type_decls.get(id) { + self.type_to_ocaml_ident(tdecl) + } else if let Some(name) = self.crate_data.item_name(id) { + eprintln!("Warning: type {} missing from llbc", repr_name(name)); + name.short_str().to_lowercase() + } else { + format!("missing_type_{id}") + }; + if base_ty == "vec" { + base_ty = "list".to_string(); + } + if base_ty == "ustr" { + base_ty = "string".to_string(); + } + if base_ty == "indexed_map" { + base_ty = if self.use_opt_index_map() { + "option list".to_string() + } else { + "list".to_string() + }; + args.remove(0); // Remove the index generic param + } + if base_ty == "index_vec" { + base_ty = "list".to_string(); + args.remove(0); // Remove the index generic param + } + if base_ty == "index_map" { + // That's the `indexmap::IndexMap` case. Translate as a list of pairs. + base_ty = "list".to_string(); + args = vec![format!("( {} * {} )", args[0], args[1])] + } + let args = match args.as_slice() { + [] => String::new(), + [arg] => arg.clone(), + args => format!("({})", args.iter().join(",")), + }; + format!("{args} {base_ty}") + } + TypeId::Builtin(BuiltinTy::Box) => args[0].clone(), + TypeId::Tuple => args.iter().join("*"), + _ => unimplemented!("{ty:?}"), + } + } + TyKind::TypeVar(DeBruijnVar::Free(id) | DeBruijnVar::Bound(_, id)) => format!("'a{id}"), + _ => unimplemented!("{ty:?}"), + } + } + + pub fn names_to_type_id_map(&self, data: &[(&str, &str)]) -> HashMap { + data.iter() + .map(|(name, def)| (self.id_from_name(name), def.to_string())) + .collect() + } + + pub fn names_to_type_id_set(&self, data: &[&str]) -> HashSet { + data.iter().map(|name| self.id_from_name(name)).collect() + } + + pub fn with_item(&mut self, new_item: &TypeDecl, f: F) -> T + where + F: FnOnce(&mut Self) -> T, + { + let (name, _) = self.type_to_ocaml_ident_raw(new_item); + let old_name = self.current_item.replace(name); + let res = f(self); + self.current_item = old_name; + res + } + + pub fn use_opt_index_map(&self) -> bool { + self.current_item == Some("translated_crate".to_string()) + } +}