Commit ea3387ff authored by Andrei Paskevich's avatar Andrei Paskevich

Mlw: rework snapshot types (wip)

parent cc509106
...@@ -24,7 +24,6 @@ type dity = ...@@ -24,7 +24,6 @@ type dity =
| Durg of ity * dity (* undestructible "user" region, for global refs *) | Durg of ity * dity (* undestructible "user" region, for global refs *)
| Dreg of dvar ref * dity (* destructible "fresh" region *) | Dreg of dvar ref * dity (* destructible "fresh" region *)
| Dapp of itysymbol * dity list * dity list | Dapp of itysymbol * dity list * dity list
| Dpur of itysymbol * dity list
and dvar = and dvar =
| Dtvs of tvsymbol (* unassigned fresh type variable *) | Dtvs of tvsymbol (* unassigned fresh type variable *)
...@@ -47,21 +46,16 @@ let dreg_fresh dity = Dreg (dvar_fresh "rho", dity) ...@@ -47,21 +46,16 @@ let dreg_fresh dity = Dreg (dvar_fresh "rho", dity)
let dity_of_ity ity = let dity_of_ity ity =
let hr = Hreg.create 3 in let hr = Hreg.create 3 in
let rec dity ity = match ity.ity_node with let rec dity ity = match ity.ity_node with
| Ityapp (s,tl,rl) -> Dapp (s, List.map dity tl, List.map dreg rl) | Ityapp (s,tl,rl) -> Dapp (s, List.map dity tl, List.map dity rl)
| Itypur (s,tl) -> Dpur (s, List.map dity tl) | Ityvar (v,_) -> Dutv v
| Ityvar v -> Dutv v
| Ityreg r -> dreg r | Ityreg r -> dreg r
and dreg reg = and dreg reg =
try Hreg.find hr reg with Not_found -> try Hreg.find hr reg with Not_found ->
let {reg_its = s; reg_args = tl; reg_regs = rl} = reg in let {reg_its = s; reg_args = tl; reg_regs = rl} = reg in
let d = Dapp (s, List.map dity tl, List.map dreg rl) in let d = Dapp (s, List.map dity tl, List.map dity rl) in
let r = dreg_fresh d in Hreg.add hr reg r; r in let r = dreg_fresh d in Hreg.add hr reg r; r in
dity ity dity ity
let reg_of_ity = function
| {ity_node = Ityreg reg} -> reg
| _ -> assert false
let rec ity_of_dity = function let rec ity_of_dity = function
| Dvar ({contents = Dval d}) | Dvar ({contents = Dval d})
| Dreg ({contents = Dval d}, _) -> | Dreg ({contents = Dval d}, _) ->
...@@ -75,17 +69,14 @@ let rec ity_of_dity = function ...@@ -75,17 +69,14 @@ let rec ity_of_dity = function
| Dutv v -> ity_var v | Dutv v -> ity_var v
| Durg (ity,_) -> ity | Durg (ity,_) -> ity
| Dapp (s,tl,rl) -> | Dapp (s,tl,rl) ->
let reg_of_dity r = reg_of_ity (ity_of_dity r) in ity_app s (List.map ity_of_dity tl) (List.map ity_of_dity rl)
ity_app s (List.map ity_of_dity tl) (List.map reg_of_dity rl)
| Dpur (s,tl) ->
ity_pur s (List.map ity_of_dity tl)
(** Destructive type unification *) (** Destructive type unification *)
let rec occur_check v = function let rec occur_check v = function
| Dvar {contents = Dval d} | Dreg (_,d) | Durg (_,d) -> occur_check v d | Dvar {contents = Dval d} | Dreg (_,d) | Durg (_,d) -> occur_check v d
| Dvar {contents = Dtvs u} | Dutv u -> if tv_equal u v then raise Exit | Dvar {contents = Dtvs u} | Dutv u -> if tv_equal u v then raise Exit
| Dapp (_,dl,_) | Dpur (_,dl) -> List.iter (occur_check v) dl | Dapp (_,dl,_) -> List.iter (occur_check v) dl
let rec dity_unify d1 d2 = match d1,d2 with let rec dity_unify d1 d2 = match d1,d2 with
| Dvar {contents = Dval d1}, d2 | Dvar {contents = Dval d1}, d2
...@@ -102,8 +93,7 @@ let rec dity_unify d1 d2 = match d1,d2 with ...@@ -102,8 +93,7 @@ let rec dity_unify d1 d2 = match d1,d2 with
r := Dval d r := Dval d
| Dutv u, Dutv v when tv_equal u v -> | Dutv u, Dutv v when tv_equal u v ->
() ()
|(Dapp (s1,dl1,_), Dapp (s2,dl2,_) | Dapp (s1,dl1,_), Dapp (s2,dl2,_) when its_equal s1 s2 ->
| Dpur (s1,dl1), Dpur (s2,dl2)) when its_equal s1 s2 ->
List.iter2 dity_unify dl1 dl2 List.iter2 dity_unify dl1 dl2
| _ -> raise Exit | _ -> raise Exit
...@@ -124,7 +114,6 @@ let rec dity_refresh ht = function ...@@ -124,7 +114,6 @@ let rec dity_refresh ht = function
let r = dreg_fresh (dity_refresh ht d) in let r = dreg_fresh (dity_refresh ht d) in
Htv.add ht v r; r end Htv.add ht v r; r end
| Dreg _ -> assert false | Dreg _ -> assert false
| Dpur (s,dl) -> Dpur (s, List.map (dity_refresh ht) dl)
| Dapp (s,dl,rl) -> Dapp (s, List.map (dity_refresh ht) dl, | Dapp (s,dl,rl) -> Dapp (s, List.map (dity_refresh ht) dl,
List.map (dity_refresh ht) rl) List.map (dity_refresh ht) rl)
| Dvar {contents = Dval d} -> dity_refresh (Htv.create 3) d | Dvar {contents = Dval d} -> dity_refresh (Htv.create 3) d
...@@ -155,8 +144,6 @@ let rec reunify d1 d2 = match d1,d2 with ...@@ -155,8 +144,6 @@ let rec reunify d1 d2 = match d1,d2 with
| Dapp (_,dl1,rl1), Dapp (_,dl2,rl2) -> | Dapp (_,dl1,rl1), Dapp (_,dl2,rl2) ->
List.iter2 reunify dl1 dl2; List.iter2 reunify dl1 dl2;
List.iter2 reunify rl1 rl2 List.iter2 reunify rl1 rl2
| Dpur (_,dl1), Dpur (_,dl2) ->
List.iter2 reunify dl1 dl2
| _ -> assert false | _ -> assert false
let reunify_regions () = let reunify_regions () =
...@@ -204,6 +191,8 @@ let rec print_dity pri fmt = function ...@@ -204,6 +191,8 @@ let rec print_dity pri fmt = function
Format.fprintf fmt (protect_on (pri > 1) "%a@ @@%s") Format.fprintf fmt (protect_on (pri > 1) "%a@ @@%s")
(print_dity 0) d (Ident.id_unique rprinter v.tv_name) (print_dity 0) d (Ident.id_unique rprinter v.tv_name)
| Durg (ity,d) -> | Durg (ity,d) ->
let reg_of_ity = function
| {ity_node = Ityreg reg} -> reg | _ -> assert false in
Format.fprintf fmt (protect_on (pri > 1) "%a@ @@%s") Format.fprintf fmt (protect_on (pri > 1) "%a@ @@%s")
(print_dity 0) d (Ident.id_unique rprinter (reg_of_ity ity).reg_name) (print_dity 0) d (Ident.id_unique rprinter (reg_of_ity ity).reg_name)
| Dapp (s,[t1;t2],[]) when its_equal s its_func -> | Dapp (s,[t1;t2],[]) when its_equal s its_func ->
...@@ -215,9 +204,11 @@ let rec print_dity pri fmt = function ...@@ -215,9 +204,11 @@ let rec print_dity pri fmt = function
Format.fprintf fmt (protect_on (pri > 1) "%a%a%a") Format.fprintf fmt (protect_on (pri > 1) "%a%a%a")
Pretty.print_ts s.its_ts (print_args (print_dity 2)) tl Pretty.print_ts s.its_ts (print_args (print_dity 2)) tl
(print_regs (print_dity 0)) rl (print_regs (print_dity 0)) rl
(*
| Dpur (s,tl) -> | Dpur (s,tl) ->
Format.fprintf fmt (protect_on (pri > 1 && tl <> []) "{%a}%a") Format.fprintf fmt (protect_on (pri > 1 && tl <> []) "{%a}%a")
Pretty.print_ts s.its_ts (print_args (print_dity 2)) tl Pretty.print_ts s.its_ts (print_args (print_dity 2)) tl
*)
let print_dity fmt d = print_dity 0 fmt d let print_dity fmt d = print_dity 0 fmt d
...@@ -231,7 +222,6 @@ let specialize_scheme tvs (argl,res) = ...@@ -231,7 +222,6 @@ let specialize_scheme tvs (argl,res) =
| Dvar {contents = Dtvs v} | Dutv v as d -> get_tv v d | Dvar {contents = Dtvs v} | Dutv v as d -> get_tv v d
| Dreg ({contents = Dtvs v},d) -> get_reg v d | Dreg ({contents = Dtvs v},d) -> get_reg v d
| Dapp (s,dl,rl) -> Dapp (s, List.map spec_dity dl, List.map spec_dity rl) | Dapp (s,dl,rl) -> Dapp (s, List.map spec_dity dl, List.map spec_dity rl)
| Dpur (s,dl) -> Dpur (s, List.map spec_dity dl)
and get_tv v d = try Htv.find hv v with Not_found -> and get_tv v d = try Htv.find hv v with Not_found ->
let nd = dity_fresh () in let nd = dity_fresh () in
(* can't return d, might differ in regions *) (* can't return d, might differ in regions *)
...@@ -245,14 +235,13 @@ let specialize_scheme tvs (argl,res) = ...@@ -245,14 +235,13 @@ let specialize_scheme tvs (argl,res) =
let spec_ity hv hr frz ity = let spec_ity hv hr frz ity =
let rec dity ity = match ity.ity_node with let rec dity ity = match ity.ity_node with
| Ityreg r -> dreg r | Ityreg r -> dreg r
| Ityvar v -> if Mtv.mem v frz.isb_tv then Dutv v else get_tv v | Ityvar (v,_) -> if Mtv.mem v frz.isb_var then Dutv v else get_tv v
| Ityapp (s,tl,rl) -> Dapp (s, List.map dity tl, List.map dreg rl) | Ityapp (s,tl,rl) -> Dapp (s, List.map dity tl, List.map dity rl)
| Itypur (s,tl) -> Dpur (s, List.map dity tl)
and get_tv v = try Htv.find hv v with Not_found -> and get_tv v = try Htv.find hv v with Not_found ->
let nd = dity_fresh () in Htv.add hv v nd; nd let nd = dity_fresh () in Htv.add hv v nd; nd
and dreg reg = try Hreg.find hr reg with Not_found -> and dreg reg = try Hreg.find hr reg with Not_found ->
let {reg_its = s; reg_args = tl; reg_regs = rl} = reg in let {reg_its = s; reg_args = tl; reg_regs = rl} = reg in
let d = Dapp (s, List.map dity tl, List.map dreg rl) in let d = Dapp (s, List.map dity tl, List.map dity rl) in
let r = if Mreg.mem reg frz.isb_reg then let r = if Mreg.mem reg frz.isb_reg then
Durg (ity_reg reg, d) else dreg_fresh d in Durg (ity_reg reg, d) else dreg_fresh d in
Hreg.add hr reg r; r in Hreg.add hr reg r; r in
...@@ -272,7 +261,7 @@ let specialize_rs {rs_cty = cty} = ...@@ -272,7 +261,7 @@ let specialize_rs {rs_cty = cty} =
let specialize_ls {ls_args = args; ls_value = res} = let specialize_ls {ls_args = args; ls_value = res} =
let hv = Htv.create 3 and hr = Hreg.create 3 in let hv = Htv.create 3 and hr = Hreg.create 3 in
let rec ity ty = match ty.ty_node with let rec ity ty = match ty.ty_node with
| Tyapp (s,tl) -> ity_app_fresh (restore_its s) (List.map ity tl) | Tyapp (s,tl) -> ity_app (restore_its s) (List.map ity tl) []
| Tyvar v -> ity_var v in | Tyvar v -> ity_var v in
let spec ty = spec_ity hv hr isb_empty (ity ty) in let spec ty = spec_ity hv hr isb_empty (ity ty) in
List.map spec args, Opt.fold (Util.const spec) dity_bool res List.map spec args, Opt.fold (Util.const spec) dity_bool res
...@@ -390,7 +379,7 @@ let freeze_dvty frozen (argl,res) = ...@@ -390,7 +379,7 @@ let freeze_dvty frozen (argl,res) =
| Dvar { contents = Dval d } -> add l d | Dvar { contents = Dval d } -> add l d
| Dvar { contents = Dtvs _ } as d -> d :: l | Dvar { contents = Dtvs _ } as d -> d :: l
| Dutv _ as d -> d :: l | Dutv _ as d -> d :: l
| Dapp (_,tl,_) | Dpur (_,tl) -> List.fold_left add l tl in | Dapp (_,tl,_) -> List.fold_left add l tl in
List.fold_left add (add frozen res) argl List.fold_left add (add frozen res) argl
let free_vars frozen (argl,res) = let free_vars frozen (argl,res) =
...@@ -399,7 +388,7 @@ let free_vars frozen (argl,res) = ...@@ -399,7 +388,7 @@ let free_vars frozen (argl,res) =
| Dvar { contents = Dval d } -> add s d | Dvar { contents = Dval d } -> add s d
| Dvar { contents = Dtvs v } | Dvar { contents = Dtvs v }
| Dutv v -> if is_frozen frozen v then s else Stv.add v s | Dutv v -> if is_frozen frozen v then s else Stv.add v s
| Dapp (_,tl,_) | Dpur (_,tl) -> List.fold_left add s tl in | Dapp (_,tl,_) -> List.fold_left add s tl in
List.fold_left add (add Stv.empty res) argl List.fold_left add (add Stv.empty res) argl
let denv_add_mono { frozen = frozen; locals = locals } id dvty = let denv_add_mono { frozen = frozen; locals = locals } id dvty =
...@@ -426,7 +415,7 @@ let denv_add_rec denv frozen0 id ((argl,res) as dvty) = ...@@ -426,7 +415,7 @@ let denv_add_rec denv frozen0 id ((argl,res) as dvty) =
| Dvar { contents = Dval d } -> is_explicit d | Dvar { contents = Dval d } -> is_explicit d
| Dvar { contents = Dtvs _ } -> false | Dvar { contents = Dtvs _ } -> false
| Dutv _ -> true | Dutv _ -> true
| Dapp (_,tl,_) | Dpur (_,tl) -> List.for_all is_explicit tl in | Dapp (_,tl,_) -> List.for_all is_explicit tl in
if List.for_all is_explicit argl && is_explicit res if List.for_all is_explicit argl && is_explicit res
then denv_add_rec_poly denv frozen0 id dvty then denv_add_rec_poly denv frozen0 id dvty
else denv_add_rec_mono denv id dvty else denv_add_rec_mono denv id dvty
...@@ -848,7 +837,7 @@ let env_empty = { ...@@ -848,7 +837,7 @@ let env_empty = {
exception UnboundLabel of string exception UnboundLabel of string
let find_old pvm (ovm,old) v = let find_old pvm (ovm,old) v =
if v.pv_ity.ity_pure then v else if v.pv_ity.ity_imm then v else
let n = v.pv_vs.vs_name.id_string in let n = v.pv_vs.vs_name.id_string in
(* if v is top-level, both ov and pv are None. (* if v is top-level, both ov and pv are None.
If v is local, ov and pv must be equal to v. If v is local, ov and pv must be equal to v.
...@@ -925,6 +914,7 @@ let cty_of_spec env bl dsp dity = ...@@ -925,6 +914,7 @@ let cty_of_spec env bl dsp dity =
let dsp = get_later env dsp ity in let dsp = get_later env dsp ity in
let _, eff = effect_of_dspec dsp in let _, eff = effect_of_dspec dsp in
let eff = eff_reset_overwritten eff in let eff = eff_reset_overwritten eff in
let eff = eff_reset eff (ity_freeregs Sreg.empty ity) in
let p = rebase_pre env preold old dsp.ds_pre in let p = rebase_pre env preold old dsp.ds_pre in
let q = create_post ity dsp.ds_post in let q = create_post ity dsp.ds_post in
let xq = create_xpost dsp.ds_xpost in let xq = create_xpost dsp.ds_xpost in
...@@ -976,7 +966,7 @@ and try_cexp uloc env ghost de0 = match de0.de_node with ...@@ -976,7 +966,7 @@ and try_cexp uloc env ghost de0 = match de0.de_node with
| DEapp (de1,de2) -> down de1 (expr uloc env de2 :: el) | DEapp (de1,de2) -> down de1 (expr uloc env de2 :: el)
| DEvar (n,_) -> app (ext_c_sym (get_rs env n)) el | DEvar (n,_) -> app (ext_c_sym (get_rs env n)) el
| DErs s -> app (ext_c_sym s) el | DErs s -> app (ext_c_sym s) el
| DEls _ when not res.ity_pure -> | DEls _ when not res.ity_imm ->
Loc.errorm "This expression must have pure type" Loc.errorm "This expression must have pure type"
| DEls s -> ext_c_pur s el argl res | DEls s -> ext_c_pur s el argl res
| _ -> app (cexp uloc env ghost de) el in | _ -> app (cexp uloc env ghost de) el in
......
...@@ -166,7 +166,8 @@ let create_projection s v = ...@@ -166,7 +166,8 @@ let create_projection s v =
let id = id_clone v.pv_vs.vs_name in let id = id_clone v.pv_vs.vs_name in
let eff = eff_ghostify v.pv_ghost eff_empty in let eff = eff_ghostify v.pv_ghost eff_empty in
let tyl = List.map ity_var s.its_ts.ts_args in let tyl = List.map ity_var s.its_ts.ts_args in
let ity = ity_app s tyl s.its_regions in let rgl = List.map ity_reg s.its_regions in
let ity = ity_app s tyl rgl in
let arg = create_pvsymbol (id_fresh "arg") ity in let arg = create_pvsymbol (id_fresh "arg") ity in
let ls = create_fsymbol id [arg.pv_vs.vs_ty] v.pv_vs.vs_ty in let ls = create_fsymbol id [arg.pv_vs.vs_ty] v.pv_vs.vs_ty in
let q = make_post (fs_app ls [t_var arg.pv_vs] v.pv_vs.vs_ty) in let q = make_post (fs_app ls [t_var arg.pv_vs] v.pv_vs.vs_ty) in
...@@ -191,12 +192,16 @@ let create_constructor ~constr id s fl = ...@@ -191,12 +192,16 @@ let create_constructor ~constr id s fl =
end else if constr < 1 then raise exn; end else if constr < 1 then raise exn;
let argl = List.map (fun a -> a.pv_vs.vs_ty) fl in let argl = List.map (fun a -> a.pv_vs.vs_ty) fl in
let tyl = List.map ity_var s.its_ts.ts_args in let tyl = List.map ity_var s.its_ts.ts_args in
let ity = ity_app s tyl s.its_regions in let rgl = List.map ity_reg s.its_regions in
let ity = ity_app s tyl rgl in
let ty = ty_of_ity ity in let ty = ty_of_ity ity in
let ls = create_fsymbol ~constr id argl ty in let ls = create_fsymbol ~constr id argl ty in
let argl = List.map (fun a -> t_var a.pv_vs) fl in let argl = List.map (fun a -> t_var a.pv_vs) fl in
let q = make_post (fs_app ls argl ty) in let q = make_post (fs_app ls argl ty) in
let c = create_cty fl [] [q] Mexn.empty Mpv.empty eff_empty ity in let eff = match ity.ity_node with
| Ityreg r -> eff_reset eff_empty (Sreg.singleton r)
| _ -> eff_empty in
let c = create_cty fl [] [q] Mexn.empty Mpv.empty eff ity in
mk_rs ls.ls_name c (RLls ls) None mk_rs ls.ls_name c (RLls ls) None
let rs_of_ls ls = let rs_of_ls ls =
...@@ -442,7 +447,7 @@ let e_ghostify gh ({e_effect = eff} as e) = ...@@ -442,7 +447,7 @@ let e_ghostify gh ({e_effect = eff} as e) =
let c_ghostify gh ({c_cty = cty} as c) = let c_ghostify gh ({c_cty = cty} as c) =
if cty.cty_effect.eff_ghost || not gh then c else if cty.cty_effect.eff_ghost || not gh then c else
let el = match c.c_node with Cfun e -> [e] | _ -> [] in let el = match c.c_node with Cfun e -> [e] | _ -> [] in
mk_cexp c.c_node (try_effect el cty_ghostify gh cty) mk_cexp c.c_node (try_effect el Ity.cty_ghostify gh cty)
(* purify expressions *) (* purify expressions *)
...@@ -645,8 +650,8 @@ let e_exec ({c_cty = cty} as c) = match cty.cty_args with ...@@ -645,8 +650,8 @@ let e_exec ({c_cty = cty} as c) = match cty.cty_args with
| _::_ as al -> | _::_ as al ->
check_effects cty; check_state cty; check_effects cty; check_state cty;
(* no need to check eff_covers since we are completely pure *) (* no need to check eff_covers since we are completely pure *)
if List.exists (fun a -> not a.pv_ity.ity_pure) al || if List.exists (fun a -> not a.pv_ity.ity_imm) al ||
not cty.cty_result.ity_pure then Loc.errorm "This function \ not cty.cty_result.ity_imm then Loc.errorm "This function \
has mutable type signature, it cannot be used as pure"; has mutable type signature, it cannot be used as pure";
let ghost = List.exists (fun a -> a.pv_ghost) al in let ghost = List.exists (fun a -> a.pv_ghost) al in
let effect = eff_bind (Spv.of_list al) cty.cty_effect in let effect = eff_bind (Spv.of_list al) cty.cty_effect in
...@@ -667,8 +672,8 @@ let c_app s vl ityl ity = ...@@ -667,8 +672,8 @@ let c_app s vl ityl ity =
mk_cexp (Capp (s,vl)) (cty_apply s.rs_cty vl ityl ity) mk_cexp (Capp (s,vl)) (cty_apply s.rs_cty vl ityl ity)
let c_pur s vl ityl ity = let c_pur s vl ityl ity =
if not ity.ity_pure then invalid_arg "Expr.c_pur"; if not (ity_pure ity) then invalid_arg "Expr.c_pur";
let v_args = List.map (create_pvsymbol (id_fresh "u")) ityl in let v_args = List.map (create_pvsymbol ~ghost:false (id_fresh "u")) ityl in
let t_args = List.map (fun v -> t_var v.pv_vs) (vl @ v_args) in let t_args = List.map (fun v -> t_var v.pv_vs) (vl @ v_args) in
let res = Opt.map (fun _ -> ty_of_ity ity) s.ls_value in let res = Opt.map (fun _ -> ty_of_ity ity) s.ls_value in
let q = make_post (t_app s t_args res) in let q = make_post (t_app s t_args res) in
...@@ -871,7 +876,7 @@ let e_raise xs e ity = ...@@ -871,7 +876,7 @@ let e_raise xs e ity =
(* snapshots, assertions, "any" *) (* snapshots, assertions, "any" *)
let e_pure t = let e_pure t =
let ity = Opt.fold (fun _ -> ity_of_ty) ity_bool t.t_ty in let ity = Opt.fold (Util.const ity_of_ty_pure) ity_bool t.t_ty in
let eff = eff_ghostify true (eff_read (t_freepvs Spv.empty t)) in let eff = eff_ghostify true (eff_read (t_freepvs Spv.empty t)) in
mk_expr (Epure t) ity eff mk_expr (Epure t) ity eff
...@@ -1099,10 +1104,12 @@ let debug_print_locs = Debug.register_info_flag "print_locs" ...@@ -1099,10 +1104,12 @@ let debug_print_locs = Debug.register_info_flag "print_locs"
~desc:"Print@ locations@ of@ identifiers@ and@ expressions." ~desc:"Print@ locations@ of@ identifiers@ and@ expressions."
let ambig_cty c = let ambig_cty c =
let sarg = List.fold_left (fun s v -> let freeze_pv v s = ity_freeze s v.pv_ity in
ity_freeze s v.pv_ity) isb_empty c.cty_args in let sarg = Spv.fold freeze_pv c.cty_effect.eff_reads isb_empty in
let sres = ity_freeze isb_empty c.cty_result in let sres = ity_freeze isb_empty c.cty_result in
not (Mtv.set_submap sres.isb_tv sarg.isb_tv) not (Mtv.set_submap sres.isb_var sarg.isb_var) ||
not (Mtv.set_submap sres.isb_pur
(Mtv.set_union sarg.isb_var sarg.isb_pur))
let ambig_ls s = let ambig_ls s =
let sarg = List.fold_left ty_freevars Stv.empty s.ls_args in let sarg = List.fold_left ty_freevars Stv.empty s.ls_args in
......
This diff is collapsed.
...@@ -16,14 +16,15 @@ open Term ...@@ -16,14 +16,15 @@ open Term
(** {2 Individual types (first-order types without effects)} *) (** {2 Individual types (first-order types without effects)} *)
type itysymbol = private { type itysymbol = private {
its_ts : tysymbol; (** pure "snapshot" type symbol *) its_ts : tysymbol; (** logical type symbol *)
its_privmut : bool; (** private mutable record type *) its_privmut : bool; (** private mutable type *)
its_mfields : pvsymbol list; (** mutable record fields *) its_mfields : pvsymbol list; (** mutable record fields *)
its_regions : region list; (** mutable shareable components *) its_regions : region list; (** shareable components *)
its_arg_imm : bool list; (** non-updatable type parameters *) its_arg_imm : bool list; (** non-updatable parameters *)
its_arg_exp : bool list; (** exposed type parameters *) its_arg_exp : bool list; (** exposed type parameters *)
its_arg_vis : bool list; (** non-ghost type parameters *) its_arg_vis : bool list; (** non-ghost type parameters *)
its_arg_frz : bool list; (** irreplaceable type parameters *) its_arg_frz : bool list; (** irreplaceable type parameters *)
its_reg_exp : bool list; (** exposed shareable components *)
its_reg_vis : bool list; (** non-ghost shareable components *) its_reg_vis : bool list; (** non-ghost shareable components *)
its_reg_frz : bool list; (** irreplaceable shareable components *) its_reg_frz : bool list; (** irreplaceable shareable components *)
its_def : ity option; (** type alias *) its_def : ity option; (** type alias *)
...@@ -31,25 +32,23 @@ type itysymbol = private { ...@@ -31,25 +32,23 @@ type itysymbol = private {
and ity = private { and ity = private {
ity_node : ity_node; ity_node : ity_node;
ity_pure : bool; ity_imm : bool;
ity_tag : Weakhtbl.tag; ity_tag : Weakhtbl.tag;
} }
and ity_node = private and ity_node = private
| Ityreg of region | Ityreg of region
(** record with mutable fields and shareable components *) (** record with mutable fields and shareable components *)
| Ityapp of itysymbol * ity list * region list | Ityapp of itysymbol * ity list * ity list
(** immutable type or algebraic type with shareable components *) (** immutable type with shareable components *)
| Itypur of itysymbol * ity list | Ityvar of tvsymbol * bool
(** pure snapshot of a mutable type *) (** type variable and its purity status *)
| Ityvar of tvsymbol
(** type variable *)
and region = private { and region = private {
reg_name : ident; reg_name : ident;
reg_its : itysymbol; reg_its : itysymbol;
reg_args : ity list; reg_args : ity list;
reg_regs : region list; reg_regs : ity list;
} }
and pvsymbol = private { and pvsymbol = private {
...@@ -120,11 +119,22 @@ val create_itysymbol_rich : ...@@ -120,11 +119,22 @@ val create_itysymbol_rich :
val restore_its : tysymbol -> itysymbol val restore_its : tysymbol -> itysymbol
(** raises [Not_found] if the argument is not a [its_ts] *) (** raises [Not_found] if the argument is not a [its_ts] *)
val its_mutable : itysymbol -> bool (* {2 Basic properties} *)
(** [its_mutable s] checks if [s] is a mutable record or an alias for one *)
val its_impure : itysymbol -> bool val its_immutable : itysymbol -> bool
(** [its_impure s] checks if [s] is mutable or has mutable components *) (** an immutable type symbol is not a mutable record nor an alias for one *)
val its_pure : itysymbol -> bool
(** a pure type symbol is immutable and has no mutable components *)
val ity_immutable : ity -> bool
(** an immutable type contains no regions (returns the [ity_imm] field) *)
val ity_pure : ity -> bool
(** a pure type is immutable and all type variables in it are pure *)
val ity_closed : ity -> bool
(** a closed type contains no type variables *)
(** {2 Type constructors} *) (** {2 Type constructors} *)
...@@ -132,38 +142,44 @@ exception BadItyArity of itysymbol * int ...@@ -132,38 +142,44 @@ exception BadItyArity of itysymbol * int
exception BadRegArity of itysymbol * int exception BadRegArity of itysymbol * int
exception NonUpdatable of itysymbol * ity exception NonUpdatable of itysymbol * ity
val create_region : preid -> itysymbol -> ity list -> region list -> region val create_region : preid -> itysymbol -> ity list -> ity list -> region
(** the type symbol must be mutable, aliases are allowed *) (** [create_region id s tl rl] creates a fresh region.
Type symbol [s] must be a mutable record or an alias for one.
If [rl] is empty, fresh subregions are created when needed. *)
val ity_reg : region -> ity val ity_app : itysymbol -> ity list -> ity list -> ity
val ity_var : tvsymbol -> ity (** [ity_app s tl rl] creates
- an [Ityapp] type, if [s] is immutable, or
- an [Ityreg] type on top of a fresh region, otherwise.
If [rl] is empty, fresh subregions are created when needed. *)
val ity_pur : itysymbol -> ity list -> ity val ity_app_pure : itysymbol -> ity list -> ity list -> ity
(** [ity_pur s tl] creates (** [ity_app s tl rl] creates an [Ityapp] type.
- an [Itypur] snapshot type if [its_impure s] is true If [rl] is empty, pure snapshots are substituted when needed. *)
- an [Ityapp (s,tl,[])] type otherwise *)
val ity_app : itysymbol -> ity list -> region list -> ity val ity_reg : region -> ity
(** [ity_app s tl rl] creates
- an [Ityreg] type with a fresh region if [its_mutable s] is true
- an [Ityapp (s,tl,rl)] type otherwise *)
val ity_app_fresh : itysymbol -> ity list -> ity val ity_var : tvsymbol -> ity
(** [ity_app_fresh] creates fresh regions where needed *)
val ty_of_ity : ity -> ty val ity_var_pure : tvsymbol -> ity
(** all aliases expanded, all regions removed *)
val ity_purify : ity -> ity
(** replaces regions with pure snapshots and variables with pure variables. *)
val ity_of_ty : ty -> ity val ity_of_ty : ty -> ity
(** snapshot type, raises [Invalid_argument] for any non-its *) (** fresh regions are created when needed and all variables are impure.
Raises [Invalid_argument] for any non-its tysymbol. *)
val ity_purify : ity -> ity val ity_of_ty_pure : ty -> ity
(** snapshot type *) (** pure snapshots are substituted when needed and all variables are pure.
Raises [Invalid_argument] for any non-its tysymbol. *)
val ty_of_ity : ity -> ty
(** {2 Generic traversal functions} *) (** {2 Generic traversal functions} *)
val ity_fold : ('a -> ity -> 'a) -> ('a -> region -> 'a) -> 'a -> ity -> 'a val ity_fold : ('a -> ity -> 'a) -> 'a -> ity -> 'a
val reg_fold : ('a -> ity -> 'a) -> ('a -> region -> 'a) -> 'a -> region -> 'a val reg_fold : ('a -> ity -> 'a) -> 'a -> region -> 'a
(** {2 Traversal functions on type symbols} *) (** {2 Traversal functions on type symbols} *)
...@@ -175,31 +191,30 @@ val reg_s_fold : ('a -> itysymbol -> 'a) -> 'a -> region -> 'a ...@@ -175,31 +191,30 @@ val reg_s_fold : ('a -> itysymbol -> 'a) -> 'a -> region -> 'a
val ity_v_fold : ('a -> tvsymbol -> 'a) -> 'a -> ity -> 'a val ity_v_fold : ('a -> tvsymbol -> 'a) -> 'a -> ity -> 'a
val reg_v_fold : ('a -> tvsymbol -> 'a) -> 'a -> region -> 'a val reg_v_fold : ('a -> tvsymbol -> 'a) -> 'a -> region -> 'a
(** {2 Traversal functions on top regions} *)
val ity_r_fold : ('a -> region -> 'a) -> 'a -> ity -> 'a
val reg_r_fold : ('a -> region -> 'a) -> 'a -> region -> 'a
(** {2 Miscellaneous type utilities} *)
val ity_freevars : Stv.t -> ity -> Stv.t val ity_freevars : Stv.t -> ity -> Stv.t
val reg_freevars : Stv.t -> region -> Stv.t val reg_freevars : Stv.t -> region -> Stv.t
val ity_v_occurs : tvsymbol -> ity -> bool val ity_v_occurs : tvsymbol -> ity -> bool
val reg_v_occurs : tvsymbol -> region -> bool val reg_v_occurs : tvsymbol -> region -> bool
(** {2 Traversal functions on top regions} *)
val ity_r_fold : ('a -> region -> 'a) -> 'a -> ity -> 'a
val reg_r_fold : ('a -> region -> 'a) -> 'a -> region -> 'a
val ity_freeregs : Sreg.t -> ity -> Sreg.t
val reg_freeregs : Sreg.t -> region -> Sreg.t
val ity_r_occurs : region -> ity -> bool val ity_r_occurs : region -> ity -> bool
val reg_r_occurs : region -> region -> bool val reg_r_occurs : region -> region -> bool
val ity_r_stale : Sreg.t -> 'a Mreg.t -> ity -> bool (** {2 Utility functions on exposed regions} *)
val reg_r_stale : Sreg.t -> 'a Mreg.t -> region -> bool
val ity_closed : ity -> bool
(* detect non-ghost type variables and regions *) val ity_r_reachable : region -> ity -> bool
val reg_r_reachable : region -> region -> bool
val ity_r_visible : Sreg.t -> ity -> Sreg.t val ity_r_stale : Sreg.t -> 'a Mreg.t -> ity -> bool
val ity_v_visible : Stv.t -> ity -> Stv.t val reg_r_stale : Sreg.t -> 'a Mreg.t -> region -> bool
(** {2 Built-in types} *) (** {2 Built-in types} *)
...@@ -225,19 +240,21 @@ val ity_tuple : ity list -> ity ...@@ -225,19 +240,21 @@ val ity_tuple : ity list -> ity
(** {2 Type matching and instantiation} *) (** {2 Type matching and instantiation} *)
type ity_subst = private { type ity_subst = private {
isb_tv : ity Mtv.t; isb_var : ity Mtv.t;
isb_reg : region Mreg.t; isb_pur : ity Mtv.t;
isb_reg : ity Mreg.t;
} }
exception TypeMismatch of ity * ity * ity_subst exception TypeMismatch of ity * ity * ity_subst
exception ImpureType of tvsymbol * ity
val isb_empty : ity_subst val isb_empty : ity_subst
val ity_match : ity_subst -> ity -> ity -> ity_subst val ity_match : ity_subst -> ity -> ity -> ity_subst
val reg_match : ity_subst -> region -> region -> ity_subst val reg_match : ity_subst -> region -> ity -> ity_subst
val its_match_args : itysymbol -> ity list -> ity_subst val its_match_args : itysymbol -> ity list -> ity_subst
val its_match_regs : itysymbol -> ity list -> region list -> ity_subst val its_match_regs : itysymbol -> ity list -> ity list -> ity_subst
val ity_freeze : ity_subst -> ity -> ity_subst (* self-match *) val ity_freeze : ity_subst -> ity -> ity_subst (* self-match *)
val reg_freeze : ity_subst -> region -> ity_subst (* self-match *) val reg_freeze : ity_subst -> region -> ity_subst (* self-match *)
...@@ -246,7 +263,7 @@ val ity_equal_check : ity -> ity -> unit ...@@ -246,7 +263,7 @@ val ity_equal_check : ity -> ity -> unit
val reg_equal_check : region -> region -> unit val reg_equal_check : region -> region -> unit
val ity_full_inst : ity_subst -> ity -> ity val ity_full_inst : ity_subst -> ity -> ity
val reg_full_inst : ity_subst -> region -> region val reg_full_inst : ity_subst -> region -> ity
(** {2 Program variables} *) (** {2 Program variables} *)
...@@ -279,6 +296,7 @@ val create_xsymbol : preid -> ity -> xsymbol ...@@ -279,6 +296,7 @@ val create_xsymbol : preid -> ity -> xsymbol
(** {2 Effects} *) (** {2 Effects} *)
exception IllegalSnapshot of ity
exception IllegalAlias of region exception IllegalAlias of region
exception AssignPrivate of region exception AssignPrivate of region
exception StaleVariable of pvsymbol * region exception StaleVariable of pvsymbol * region
...@@ -317,7 +335,7 @@ val eff_read_single_post : effect -> pvsymbol -> effect ...@@ -317,7 +335,7 @@ val eff_read_single_post : effect -> pvsymbol -> effect
val eff_bind_single : pvsymbol -> effect -> effect val eff_bind_single : pvsymbol -> effect -> effect
val eff_reset : effect -> Sreg.t -> effect (* confine to an empty cover *) val eff_reset : effect -> Sreg.t -> effect (* confine to an empty cover *)
val eff_reset_overwritten : effect -> effect (* confine all subregions under writes *) val eff_reset_overwritten : effect -> effect (* confine regions under writes *)