Commit 6df22605 authored by Andrei Paskevich's avatar Andrei Paskevich

Pmodule: record refinement

parent 81c4153e
...@@ -525,45 +525,47 @@ let rec clone_ity cl ity = match ity.ity_node with ...@@ -525,45 +525,47 @@ let rec clone_ity cl ity = match ity.ity_node with
| Ityreg r -> | Ityreg r ->
ity_reg (clone_reg cl r) ity_reg (clone_reg cl r)
| Ityapp (s, tl, rl) -> | Ityapp (s, tl, rl) ->
let tl = List.map (clone_ity cl) tl in let tl' = List.map (clone_ity cl) tl in
let rl = List.map (clone_ity cl) rl in
begin match Mts.find_opt s.its_ts cl.ts_table with begin match Mts.find_opt s.its_ts cl.ts_table with
| Some its -> ity_app_pure its tl rl | Some s' -> ity_app_pure s' tl' (clone_regs cl s tl rl s')
| None -> (* creative indentation *) | None -> (* creative indentation *)
begin match Mts.find_opt s.its_ts cl.ty_table with begin match Mts.find_opt s.its_ts cl.ty_table with
| Some ity -> ity_full_inst (its_match_regs s tl rl) ity | Some ity -> ity_full_inst (its_match_regs s tl' []) ity
| None -> ity_app_pure s tl rl | None -> ity_app_pure s tl' (List.map (clone_ity cl) rl)
end end end end
| Ityvar _ -> ity | Ityvar _ -> ity
and clone_reg cl reg = and clone_reg cl reg =
(* FIXME: what about top-level non-instantiated regions?
We cannot check in cl.cl_local to see if they are there.
Instead, we should prefill cl.pv_table and cl.rn_table
with all top-level pvsymbols (local or external) before
descending into a let_defn.
TODO: add to module/uc a list of locally-defined toplevel
variables, as well as a set of imported toplevel variables. *)
try Mreg.find reg cl.rn_table with Not_found -> try Mreg.find reg cl.rn_table with Not_found ->
let tl = List.map (clone_ity cl) reg.reg_args in let tl' = List.map (clone_ity cl) reg.reg_args in
let rl = List.map (clone_ity cl) reg.reg_regs in let s',rl' = match Mts.find_opt reg.reg_its.its_ts cl.ts_table with
let r = match Mts.find_opt reg.reg_its.its_ts cl.ts_table with | Some s' -> s', clone_regs cl reg.reg_its reg.reg_args reg.reg_regs s'
| Some its -> | None -> reg.reg_its, List.map (clone_ity cl) reg.reg_regs in
create_region (id_clone reg.reg_name) its tl rl let r = create_region (id_clone reg.reg_name) s' tl' rl' in
| None -> (* creative indentation *)
begin match Mts.find_opt reg.reg_its.its_ts cl.ty_table with
| Some {ity_node = Ityreg r} ->
let sbs = its_match_regs reg.reg_its tl rl in
let tl = List.map (ity_full_inst sbs) r.reg_args in
let rl = List.map (ity_full_inst sbs) r.reg_regs in
create_region (id_clone reg.reg_name) r.reg_its tl rl
| Some _ -> assert false
| None ->
create_region (id_clone reg.reg_name) reg.reg_its tl rl
end in
cl.rn_table <- Mreg.add reg r cl.rn_table; cl.rn_table <- Mreg.add reg r cl.rn_table;
r r
and clone_regs cl s tl rl s' =
if rl = [] then [] else
let base = its_match_regs s tl rl in
let add sbs pj =
let ity = clone_ity cl (ity_full_inst base pj.pv_ity) in
ity_match sbs (Mpv.find pj cl.fd_table).pv_ity ity in
let sbs = List.fold_left add isb_empty s.its_mfields in
let sbs = List.fold_left add sbs s.its_ofields in
let rec inst ity =
if ity.ity_pure then ity_full_inst sbs ity else
match ity.ity_node with
| Ityreg r when Mreg.mem r sbs.isb_reg ->
Mreg.find r sbs.isb_reg
| Ityreg {reg_its = s; reg_args = tl; reg_regs = rl} ->
ity_app s (List.map inst tl) (List.map inst rl)
| Ityapp (s,tl,rl) ->
ity_app_pure s (List.map inst tl) (List.map inst rl)
| Ityvar v ->
Mtv.find v sbs.isb_var in
List.map (fun reg -> inst (ity_reg reg)) s'.its_regions
let cl_find_ls cl ls = let cl_find_ls cl ls =
if not (Sid.mem ls.ls_name cl.cl_local) then ls if not (Sid.mem ls.ls_name cl.cl_local) then ls
else Mls.find ls cl.ls_table else Mls.find ls cl.ls_table
...@@ -596,11 +598,15 @@ let cl_init m inst = ...@@ -596,11 +598,15 @@ let cl_init m inst =
Mts.iter (fun ts _ -> non_local ts.ts_name) inst.mi_ty; Mts.iter (fun ts _ -> non_local ts.ts_name) inst.mi_ty;
let check_ls ls _ = let check_ls ls _ =
non_local ls.ls_name; non_local ls.ls_name;
(* TODO: Loc.errorm "`ls` is a program function, it cannot
be instantiated with a logical symbol" *)
try ignore (restore_rs ls); raise (BadInstance (BadI ls.ls_name)) try ignore (restore_rs ls); raise (BadInstance (BadI ls.ls_name))
with Not_found -> () in with Not_found -> () in
Mls.iter check_ls inst.mi_ls; Mls.iter check_ls inst.mi_ls;
let check_rs rs _ = let check_rs rs _ =
non_local rs.rs_name; non_local rs.rs_name;
(* TODO: Loc.errorm "`rs` is a constructor/projection,
it cannot be instantiated" *)
match (Mid.find rs.rs_name m.mod_known).pd_node with match (Mid.find rs.rs_name m.mod_known).pd_node with
| PDtype _ -> raise (BadInstance (BadI rs.rs_name)) | PDtype _ -> raise (BadInstance (BadI rs.rs_name))
| PDlet _ | PDexn _ | PDpure -> () in | PDlet _ | PDexn _ | PDpure -> () in
...@@ -690,9 +696,9 @@ let cl_save_rs cl s s' = ...@@ -690,9 +696,9 @@ let cl_save_rs cl s s' =
end; end;
match s.rs_logic, s'.rs_logic with match s.rs_logic, s'.rs_logic with
| RLls s, RLls s' -> cl_save_ls cl s s' | RLls s, RLls s' -> cl_save_ls cl s s'
| RLnone, (RLnone | RLls _ | RLlemma) -> ()
| RLlemma, RLlemma -> () (* TODO: update cl.pr_table? *) | RLlemma, RLlemma -> () (* TODO: update cl.pr_table? *)
| RLnone, RLnone -> () | _ -> raise (BadInstance (BadI s.rs_name))
| _ -> assert false
type smap = { type smap = {
sm_vs : vsymbol Mvs.t; sm_vs : vsymbol Mvs.t;
...@@ -908,29 +914,64 @@ and clone_let_defn cl sm ld = match ld with ...@@ -908,29 +914,64 @@ and clone_let_defn cl sm ld = match ld with
let clone_type_record cl s d s' d' = let clone_type_record cl s d s' d' =
let id = s.its_ts.ts_name in let id = s.its_ts.ts_name in
let fields' = Hstr.create 16 in let fields' = Hstr.create 16 in
let matched_fields' = Hpv.create 16 in
let add_field' rs' = let pj' = fd_of_rs rs' in let add_field' rs' = let pj' = fd_of_rs rs' in
Hstr.add fields' pj'.pv_vs.vs_name.id_string rs' in Hstr.add fields' pj'.pv_vs.vs_name.id_string rs' in
List.iter add_field' d'.itd_fields; List.iter add_field' d'.itd_fields;
(* check if fields from former type are also declared in the new type *) (* refinement preserves (im)mutability *)
let match_pj rs = let pj = fd_of_rs rs in if not (s.its_mutable = s'.its_mutable) then
raise (BadInstance (BadI id));
(* the fields from the old type must appear in the new type *)
let match_pj (bsb,fsb) rs =
let pj = fd_of_rs rs in
let pj_str = pj.pv_vs.vs_name.id_string in let pj_str = pj.pv_vs.vs_name.id_string in
let pj_ity = clone_ity cl pj.pv_ity in let pj_ity = clone_ity cl pj.pv_ity in
let pj_ght = pj.pv_ghost in let pj_ght = pj.pv_ghost in
let pj_mut = List.exists (pv_equal pj) s.its_mfields in
let rs' = try Hstr.find fields' pj_str with Not_found -> let rs' = try Hstr.find fields' pj_str with Not_found ->
raise (BadInstance (BadI_not_found (id, pj_str))) in raise (BadInstance (BadI_not_found (id, pj_str))) in
let pj' = fd_of_rs rs' in let pj' = fd_of_rs rs' in
let pj'_ity = pj'.pv_ity in let pj'_ity = pj'.pv_ity in
let pj'_ght = pj'.pv_ghost in let pj'_ght = pj'.pv_ghost in
let equal_pjs = ity_equal pj_ity pj'_ity in let pj'_mut = List.exists (pv_equal pj') s'.its_mfields in
if not equal_pjs then let bsb = try ity_match bsb pj'_ity pj_ity with TypeMismatch _ ->
raise (BadInstance (BadI_type_proj (id, pj.pv_vs.vs_name.id_string))); raise (BadInstance (BadI_type_proj (id, pj_str))) in
let fsb = try ity_match fsb pj_ity pj'_ity with TypeMismatch _ ->
raise (BadInstance (BadI_type_proj (id, pj_str))) in
if not (pj_ght || not pj'_ght) then if not (pj_ght || not pj'_ght) then
raise (BadInstance (BadI_ghost_proj (id, pj.pv_vs.vs_name.id_string))); raise (BadInstance (BadI_ghost_proj (id, pj_str)));
if not (pj_mut = pj'_mut) then (* TODO: dedicated BadI *)
raise (BadInstance (BadI_type_proj (id, pj_str)));
let ls, ls' = ls_of_rs rs, ls_of_rs rs' in let ls, ls' = ls_of_rs rs, ls_of_rs rs' in
cl.ls_table <- Mls.add ls ls' cl.ls_table; cl.ls_table <- Mls.add ls ls' cl.ls_table;
cl.rs_table <- Mrs.add rs rs' cl.rs_table; cl.rs_table <- Mrs.add rs rs' cl.rs_table;
cl.fd_table <- Mpv.add pj pj' cl.fd_table in cl.fd_table <- Mpv.add pj pj' cl.fd_table;
List.iter match_pj d.itd_fields; Hpv.add matched_fields' pj' pj;
bsb, fsb in
ignore (List.fold_left match_pj (isb_empty,isb_empty) d.itd_fields);
(* the new fields must be separated from the old ones *)
let check_npj' (op,np) rs' =
let pj' = fd_of_rs rs' in
if Hpv.mem matched_fields' pj' then ity_freeze op pj'.pv_ity, np
else op, ity_freeze np pj'.pv_ity in
let op,np = List.fold_left check_npj' (isb_empty,isb_empty) d'.itd_fields in
if not (Mreg.set_disjoint op.isb_reg np.isb_reg) then
raise (BadInstance (BadI id));
(* NOTE: shouldn't be necessary
(* cannot add fields with regions to an immutable type *)
if not s.its_mutable && not (Mreg.is_empty np.isb_reg) then
raise (BadInstance (BadI id));
*)
(* if we refine a mutable type, then all new regions in the invariant
come from the new fields (no invariant strengthening on the old ones) *)
let pj_occurs pj f = t_v_occurs pj.pv_vs f > 0 in
let check_opj' pj' pj =
if not pj'.pv_ity.ity_pure &&
List.exists (pj_occurs pj') d'.itd_invariant &&
not (List.exists (pj_occurs pj) d.itd_invariant) then
raise (BadInstance (BadI id)) in
Hpv.iter check_opj' matched_fields';
(* validate the refinement *)
cl.ts_table <- Mts.add s.its_ts s' cl.ts_table cl.ts_table <- Mts.add s.its_ts s' cl.ts_table
let clone_type_decl inst cl tdl kn = let clone_type_decl inst cl tdl kn =
...@@ -969,7 +1010,7 @@ let clone_type_decl inst cl tdl kn = ...@@ -969,7 +1010,7 @@ let clone_type_decl inst cl tdl kn =
let pd' = Mid.find s'.its_ts.ts_name kn in let pd' = Mid.find s'.its_ts.ts_name kn in
let d' = match pd'.pd_node with let d' = match pd'.pd_node with
| PDtype [d'] -> d' | PDtype [d'] -> d'
(* FIXME: we could refine with mutual types *) (* FIXME? we could refine with mutual types *)
| PDtype _ -> raise (BadInstance (BadI id)) | PDtype _ -> raise (BadInstance (BadI id))
| PDlet _ | PDexn _ | PDpure -> raise (BadInstance (BadI id)) in | PDlet _ | PDexn _ | PDpure -> raise (BadInstance (BadI id)) in
clone_type_record cl s d s' d'; (* clone record fields *) clone_type_record cl s d s' d'; (* clone record fields *)
...@@ -981,16 +1022,14 @@ let clone_type_decl inst cl tdl kn = ...@@ -981,16 +1022,14 @@ let clone_type_decl inst cl tdl kn =
List.iter add_vc invl end List.iter add_vc invl end
| None -> begin match Mts.find_opt ts inst.mi_ty with | None -> begin match Mts.find_opt ts inst.mi_ty with
| Some ity -> (* creative indentation *) | Some ity -> (* creative indentation *)
(* TODO: clone_type_record, axiom_of_invariant *)
(* TODO: should we only allow cloning into ity for
private types with no fields and no invariant? *)
let stv = Stv.of_list ts.ts_args in let stv = Stv.of_list ts.ts_args in
if not (Stv.subset (ity_freevars Stv.empty ity) stv && if not (Stv.subset (ity_freevars Stv.empty ity) stv &&
its_pure s && ity.ity_pure) then raise (BadInstance (BadI id)); d.itd_fields = [] && d.itd_invariant = [] &&
its_pure s && ity.ity_pure) then
raise (BadInstance (BadI id));
cl.ty_table <- Mts.add ts ity cl.ty_table cl.ty_table <- Mts.add ts ity cl.ty_table
| None -> assert false end end; | None -> assert false end end;
Hits.add htd s None; Hits.add htd s None;
(* TODO: check typing conditions for refined record type *)
end else end else
(* variant *) (* variant *)
if not s.its_mutable && d.itd_constructors <> [] && if not s.its_mutable && d.itd_constructors <> [] &&
...@@ -1085,6 +1124,7 @@ let clone_pdecl inst cl uc d = match d.pd_node with ...@@ -1085,6 +1124,7 @@ let clone_pdecl inst cl uc d = match d.pd_node with
let add uc d = add_pdecl ~warn:false ~vc:false uc d in let add uc d = add_pdecl ~warn:false ~vc:false uc d in
List.fold_left add uc dl List.fold_left add uc dl
| PDlet (LDsym (rs, c)) when Mrs.mem rs inst.mi_rs -> | PDlet (LDsym (rs, c)) when Mrs.mem rs inst.mi_rs ->
freeze_foreign cl (cty_reads c.c_cty);
(* refine only [val] symbols *) (* refine only [val] symbols *)
let cty = match c.c_node with (* cty for [val constant] is not c.c_cty *) let cty = match c.c_node with (* cty for [val constant] is not c.c_cty *)
| Cany -> c.c_cty | Cany -> c.c_cty
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment