Skip to content

Commit

Permalink
Update following changes in Charon
Browse files Browse the repository at this point in the history
  • Loading branch information
sonmarcho committed Feb 8, 2024
1 parent 689954a commit e30d4f1
Show file tree
Hide file tree
Showing 11 changed files with 34 additions and 72 deletions.
25 changes: 9 additions & 16 deletions compiler/AssociatedTypes.ml
Original file line number Diff line number Diff line change
Expand Up @@ -51,9 +51,10 @@ let compute_norm_trait_types_from_preds
that it would be enough to only visit the field [ty] of the trait type
constraint, but for safety we visit all the fields *)
assert (trait_type_constraint_no_regions c);
let trait_ty = TTraitType (c.trait_ref, c.generics, c.type_name) in
let { trait_ref; type_name; ty } : trait_type_constraint = c in
let trait_ty = TTraitType (trait_ref, type_name) in
let trait_ty_ref = get_ref trait_ty in
let ty_ref = get_ref c.ty in
let ty_ref = get_ref ty in
let new_repr = UnionFind.get ty_ref in
let merged = UnionFind.union trait_ty_ref ty_ref in
(* Not sure the set operation is necessary, but I want to control which
Expand All @@ -72,9 +73,7 @@ let compute_norm_trait_types_from_preds
List.filter_map
(fun (k, v) ->
match k with
| TTraitType (trait_ref, generics, type_name) ->
assert (generics = empty_generic_args);
Some ({ trait_ref; type_name }, v)
| TTraitType (trait_ref, type_name) -> Some ({ trait_ref; type_name }, v)
| _ -> None)
rbindings
in
Expand Down Expand Up @@ -225,20 +224,15 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty =
let inputs = List.map (norm_ctx_normalize_ty ctx) inputs in
let output = norm_ctx_normalize_ty ctx output in
TArrow (regions, inputs, output)
| TTraitType (trait_ref, generics, type_name) -> (
| TTraitType (trait_ref, type_name) -> (
log#ldebug
(lazy
("norm_ctx_normalize_ty:\n- trait type: " ^ ty_to_string ctx ty
^ "\n- trait_ref: "
^ trait_ref_to_string ctx trait_ref
^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref
^ "\n- generics:\n"
^ generic_args_to_string ctx generics));
^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref));
(* Normalize and attempt to project the type from the trait ref *)
let trait_ref = norm_ctx_normalize_trait_ref ctx trait_ref in
let generics = norm_ctx_normalize_generic_args ctx generics in
(* For now, we don't support higher order types *)
assert (generics = empty_generic_args);
let ty : ty =
match trait_ref.trait_id with
| TraitRef { trait_id = TraitImpl impl_id; generics = ref_generics; _ }
Expand Down Expand Up @@ -284,7 +278,7 @@ let rec norm_ctx_normalize_ty (ctx : norm_ctx) (ty : ty) : ty =
^ "\n- raw trait ref:\n" ^ show_trait_ref trait_ref));
(* We can't project *)
assert (trait_instance_id_is_local_clause trait_ref.trait_id);
TTraitType (trait_ref, generics, type_name)
TTraitType (trait_ref, type_name)
in
let tr : trait_type_ref = { trait_ref; type_name } in
(* Lookup the representative, if there is *)
Expand Down Expand Up @@ -484,11 +478,10 @@ and norm_ctx_normalize_trait_decl_ref (ctx : norm_ctx)

let norm_ctx_normalize_trait_type_constraint (ctx : norm_ctx)
(ttc : trait_type_constraint) : trait_type_constraint =
let { trait_ref; generics; type_name; ty } = ttc in
let { trait_ref; type_name; ty } : trait_type_constraint = ttc in
let trait_ref = norm_ctx_normalize_trait_ref ctx trait_ref in
let generics = norm_ctx_normalize_generic_args ctx generics in
let ty = norm_ctx_normalize_ty ctx ty in
{ trait_ref; generics; type_name; ty }
{ trait_ref; type_name; ty }

let mk_norm_ctx (ctx : eval_ctx) : norm_ctx =
{
Expand Down
6 changes: 1 addition & 5 deletions compiler/Extract.ml
Original file line number Diff line number Diff line change
Expand Up @@ -357,19 +357,15 @@ and extract_App (ctx : extraction_ctx) (fmt : F.formatter) (inside : bool)
extract_adt_cons ctx fmt inside adt_cons_id qualif.generics args
| Proj proj ->
extract_field_projector ctx fmt inside app proj qualif.generics args
| TraitConst (trait_ref, generics, const_name) ->
let use_brackets = generics <> empty_generic_args in
if use_brackets then F.pp_print_string fmt "(";
| TraitConst (trait_ref, const_name) ->
extract_trait_ref ctx fmt TypeDeclId.Set.empty false trait_ref;
extract_generic_args ctx fmt TypeDeclId.Set.empty generics;
let name =
ctx_get_trait_const trait_ref.trait_decl_ref.trait_decl_id
const_name ctx
in
let add_brackets (s : string) =
if !backend = Coq then "(" ^ s ^ ")" else s
in
if use_brackets then F.pp_print_string fmt ")";
F.pp_print_string fmt ("." ^ add_brackets name))
| _ ->
(* "Regular" expression *)
Expand Down
2 changes: 1 addition & 1 deletion compiler/ExtractBase.ml
Original file line number Diff line number Diff line change
Expand Up @@ -1789,7 +1789,7 @@ let ctx_compute_var_basename (ctx : extraction_ctx) (basename : string option)
| TLiteral lty -> (
match lty with TBool -> "b" | TChar -> "c" | TInteger _ -> "i")
| TArrow _ -> "f"
| TTraitType (_, _, name) -> name_from_type_ident name)
| TTraitType (_, name) -> name_from_type_ident name)

(** Generates a type variable basename. *)
let ctx_compute_type_var_basename (_ctx : extraction_ctx) (basename : string) :
Expand Down
7 changes: 1 addition & 6 deletions compiler/ExtractTypes.ml
Original file line number Diff line number Diff line change
Expand Up @@ -533,7 +533,7 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter)
F.pp_print_space fmt ();
extract_rec false ret_ty;
if inside then F.pp_print_string fmt ")"
| TTraitType (trait_ref, generics, type_name) -> (
| TTraitType (trait_ref, type_name) -> (
if !parameterize_trait_types then raise (Failure "Unimplemented")
else
let type_name =
Expand All @@ -552,19 +552,14 @@ let rec extract_ty (ctx : extraction_ctx) (fmt : F.formatter)
*)
match trait_ref.trait_id with
| Self ->
assert (generics = empty_generic_args);
assert (trait_ref.generics = empty_generic_args);
extract_trait_instance_id_with_dot ctx fmt no_params_tys false
trait_ref.trait_id;
F.pp_print_string fmt type_name
| _ ->
(* HOL4 doesn't have 1st class types *)
assert (!backend <> HOL4);
let use_brackets = generics <> empty_generic_args in
if use_brackets then F.pp_print_string fmt "(";
extract_trait_ref ctx fmt no_params_tys false trait_ref;
extract_generic_args ctx fmt no_params_tys generics;
if use_brackets then F.pp_print_string fmt ")";
F.pp_print_string fmt ("." ^ add_brackets type_name))

and extract_trait_ref (ctx : extraction_ctx) (fmt : F.formatter)
Expand Down
6 changes: 2 additions & 4 deletions compiler/InterpreterExpressions.ml
Original file line number Diff line number Diff line change
Expand Up @@ -263,8 +263,7 @@ let eval_operand_no_reorganize (config : config) (op : operand)
match cv.value with
| CLiteral lit ->
cf (literal_to_typed_value (ty_as_literal cv.ty) lit) ctx
| CTraitConst (trait_ref, generics, const_name) -> (
assert (generics = empty_generic_args);
| CTraitConst (trait_ref, const_name) -> (
match trait_ref.trait_id with
| TraitImpl _ ->
(* This shouldn't happen: if we refer to a concrete implementation, we
Expand Down Expand Up @@ -294,8 +293,7 @@ let eval_operand_no_reorganize (config : config) (op : operand)
( ctx0,
None,
value_as_symbolic v.value,
SymbolicAst.VaTraitConstValue
(trait_ref, generics, const_name),
SymbolicAst.VaTraitConstValue (trait_ref, const_name),
e ))))
| CVar vid -> (
let ctx0 = ctx in
Expand Down
18 changes: 4 additions & 14 deletions compiler/PrintPure.ml
Original file line number Diff line number Diff line change
Expand Up @@ -159,14 +159,9 @@ let rec ty_to_string (env : fmt_env) (inside : bool) (ty : ty) : string =
ty_to_string env true arg_ty ^ " -> " ^ ty_to_string env false ret_ty
in
if inside then "(" ^ ty ^ ")" else ty
| TTraitType (trait_ref, generics, type_name) ->
| TTraitType (trait_ref, type_name) ->
let trait_ref = trait_ref_to_string env false trait_ref in
let s =
if generics = empty_generic_args then trait_ref ^ "::" ^ type_name
else
let generics = generic_args_to_string env generics in
"(" ^ trait_ref ^ " " ^ generics ^ ")::" ^ type_name
in
let s = trait_ref ^ "::" ^ type_name in
if inside then "(" ^ s ^ ")" else s

and generic_args_to_strings (env : fmt_env) (inside : bool)
Expand Down Expand Up @@ -632,14 +627,9 @@ and app_to_string (env : fmt_env) (inside : bool) (indent : string)
let field_s = adt_field_to_string env adt_id field_id in
(* Adopting an F*-like syntax *)
(ConstStrings.constructor_prefix ^ adt_s ^ "?." ^ field_s, [])
| TraitConst (trait_ref, generics, const_name) ->
| TraitConst (trait_ref, const_name) ->
let trait_ref = trait_ref_to_string env true trait_ref in
let generics_s = generic_args_to_string env generics in
let qualif =
if generics <> empty_generic_args then
"(" ^ trait_ref ^ generics_s ^ ")." ^ const_name
else trait_ref ^ "." ^ const_name
in
let qualif = trait_ref ^ "." ^ const_name in
(qualif, []))
| _ ->
(* "Regular" expression case *)
Expand Down
6 changes: 2 additions & 4 deletions compiler/Pure.ml
Original file line number Diff line number Diff line change
Expand Up @@ -283,7 +283,7 @@ type ty =
| TVar of type_var_id
| TLiteral of literal_type
| TArrow of ty * ty
| TTraitType of trait_ref * generic_args * string
| TTraitType of trait_ref * string
(** The string is for the name of the associated type *)

and trait_ref = {
Expand Down Expand Up @@ -374,7 +374,6 @@ type generic_params = {

type trait_type_constraint = {
trait_ref : trait_ref;
generics : generic_args;
type_name : trait_item_name;
ty : ty;
}
Expand Down Expand Up @@ -600,8 +599,7 @@ type qualif_id =
| Global of global_decl_id
| AdtCons of adt_cons_id (** A function or ADT constructor identifier *)
| Proj of projection (** Field projector *)
| TraitConst of trait_ref * generic_args * string
(** A trait associated constant *)
| TraitConst of trait_ref * string (** A trait associated constant *)
[@@deriving show]

(** An instantiated qualifier.
Expand Down
2 changes: 1 addition & 1 deletion compiler/RegionsHierarchy.ml
Original file line number Diff line number Diff line change
Expand Up @@ -169,7 +169,7 @@ let compute_regions_hierarchy_for_sig (type_decls : type_decl TypeDeclId.Map.t)
(* Continue *)
explore_ty outer ty
| TRawPtr (ty, _) -> explore_ty outer ty
| TTraitType (trait_ref, _generic_args, _) ->
| TTraitType (trait_ref, _) ->
(* The trait should reference a clause, and not an implementation
(otherwise it should have been normalized) *)
assert (
Expand Down
3 changes: 1 addition & 2 deletions compiler/SymbolicAst.ml
Original file line number Diff line number Diff line change
Expand Up @@ -252,8 +252,7 @@ and value_aggregate =
| VaCgValue of const_generic_var_id
(** This is used when evaluating a const generic value: in the interpreter,
we introduce a fresh symbolic value. *)
| VaTraitConstValue of trait_ref * generic_args * string
(** A trait constant value *)
| VaTraitConstValue of trait_ref * string (** A trait constant value *)
[@@deriving
show,
visitors
Expand Down
28 changes: 11 additions & 17 deletions compiler/SymbolicToPure.ml
Original file line number Diff line number Diff line change
Expand Up @@ -469,10 +469,9 @@ let rec translate_sty (ty : T.ty) : ty =
let ty = translate ty in
let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in
TAdt (TAssumed (TRawPtr mut), generics)
| TTraitType (trait_ref, generics, type_name) ->
| TTraitType (trait_ref, type_name) ->
let trait_ref = translate_strait_ref trait_ref in
let generics = translate_sgeneric_args generics in
TTraitType (trait_ref, generics, type_name)
TTraitType (trait_ref, type_name)
| TArrow _ -> raise (Failure "TODO")

and translate_sgeneric_args (generics : T.generic_args) : generic_args =
Expand All @@ -492,11 +491,10 @@ let translate_trait_clause (clause : T.trait_clause) : trait_clause =

let translate_strait_type_constraint (ttc : T.trait_type_constraint) :
trait_type_constraint =
let { T.trait_ref; generics; type_name; ty } = ttc in
let { T.trait_ref; type_name; ty } = ttc in
let trait_ref = translate_strait_ref trait_ref in
let generics = translate_sgeneric_args generics in
let ty = translate_sty ty in
{ trait_ref; generics; type_name; ty }
{ trait_ref; type_name; ty }

let translate_predicates (preds : T.predicates) : predicates =
let trait_type_constraints =
Expand Down Expand Up @@ -633,10 +631,9 @@ let rec translate_fwd_ty (type_infos : type_infos) (ty : T.ty) : ty =
let ty = translate ty in
let generics = { types = [ ty ]; const_generics = []; trait_refs = [] } in
TAdt (TAssumed (TRawPtr mut), generics)
| TTraitType (trait_ref, generics, type_name) ->
| TTraitType (trait_ref, type_name) ->
let trait_ref = translate_fwd_trait_ref type_infos trait_ref in
let generics = translate_fwd_generic_args type_infos generics in
TTraitType (trait_ref, generics, type_name)
TTraitType (trait_ref, type_name)
| TArrow _ -> raise (Failure "TODO")

and translate_fwd_generic_args (type_infos : type_infos)
Expand Down Expand Up @@ -732,16 +729,14 @@ let rec translate_back_ty (type_infos : type_infos)
| TRawPtr _ ->
(* TODO: not sure what to do here *)
None
| TTraitType (trait_ref, generics, type_name) ->
assert (generics.regions = []);
| TTraitType (trait_ref, type_name) ->
assert (
AssociatedTypes.trait_instance_id_is_local_clause trait_ref.trait_id);
if inside_mut then
(* Translate the trait ref and the generics as "forward" generics -
(* Translate the trait ref as a "forward" trait ref -
we do not want to filter any type *)
let trait_ref = translate_fwd_trait_ref type_infos trait_ref in
let generics = translate_fwd_generic_args type_infos generics in
Some (TTraitType (trait_ref, generics, type_name))
Some (TTraitType (trait_ref, type_name))
else None
| TArrow _ -> raise (Failure "TODO")

Expand Down Expand Up @@ -3031,11 +3026,10 @@ and translate_intro_symbolic (ectx : C.eval_ctx) (p : S.mplace option)
in
{ e = StructUpdate su; ty = var.ty }
| VaCgValue cg_id -> { e = CVar cg_id; ty = var.ty }
| VaTraitConstValue (trait_ref, generics, const_name) ->
| VaTraitConstValue (trait_ref, const_name) ->
let type_infos = ctx.type_ctx.type_infos in
let trait_ref = translate_fwd_trait_ref type_infos trait_ref in
let generics = translate_fwd_generic_args type_infos generics in
let qualif_id = TraitConst (trait_ref, generics, const_name) in
let qualif_id = TraitConst (trait_ref, const_name) in
let qualif = { id = qualif_id; generics = empty_generic_args } in
{ e = Qualif qualif; ty = var.ty }
in
Expand Down
3 changes: 1 addition & 2 deletions compiler/TypesUtils.ml
Original file line number Diff line number Diff line change
Expand Up @@ -105,9 +105,8 @@ let generic_args_no_regions (x : generic_args) : bool =
(** Return [true] if the trait type constraint doesn't contain regions (including erased regions) *)
let trait_type_constraint_no_regions (x : trait_type_constraint) : bool =
try
let { trait_ref; generics; type_name = _; ty } = x in
let { trait_ref; type_name = _; ty } = x in
raise_if_region_ty_visitor#visit_trait_ref () trait_ref;
raise_if_region_ty_visitor#visit_generic_args () generics;
raise_if_region_ty_visitor#visit_ty () ty;
true
with Found -> false
Expand Down

0 comments on commit e30d4f1

Please sign in to comment.