Commit ea3387ff authored by Andrei Paskevich's avatar Andrei Paskevich

Mlw: rework snapshot types (wip)

parent cc509106
......@@ -24,7 +24,6 @@ type dity =
| Durg of ity * dity (* undestructible "user" region, for global refs *)
| Dreg of dvar ref * dity (* destructible "fresh" region *)
| Dapp of itysymbol * dity list * dity list
| Dpur of itysymbol * dity list
and dvar =
| Dtvs of tvsymbol (* unassigned fresh type variable *)
......@@ -47,21 +46,16 @@ let dreg_fresh dity = Dreg (dvar_fresh "rho", dity)
let dity_of_ity ity =
let hr = Hreg.create 3 in
let rec dity ity = match ity.ity_node with
| Ityapp (s,tl,rl) -> Dapp (s, List.map dity tl, List.map dreg rl)
| Itypur (s,tl) -> Dpur (s, List.map dity tl)
| Ityvar v -> Dutv v
| Ityapp (s,tl,rl) -> Dapp (s, List.map dity tl, List.map dity rl)
| Ityvar (v,_) -> Dutv v
| Ityreg r -> dreg r
and dreg reg =
try Hreg.find hr reg with Not_found ->
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
dity ity
let reg_of_ity = function
| {ity_node = Ityreg reg} -> reg
| _ -> assert false
let rec ity_of_dity = function
| Dvar ({contents = Dval d})
| Dreg ({contents = Dval d}, _) ->
......@@ -75,17 +69,14 @@ let rec ity_of_dity = function
| Dutv v -> ity_var v
| Durg (ity,_) -> ity
| 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 reg_of_dity rl)
| Dpur (s,tl) ->
ity_pur s (List.map ity_of_dity tl)
ity_app s (List.map ity_of_dity tl) (List.map ity_of_dity rl)
(** Destructive type unification *)
let rec occur_check v = function
| 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
| 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
| Dvar {contents = Dval d1}, d2
......@@ -102,8 +93,7 @@ let rec dity_unify d1 d2 = match d1,d2 with
r := Dval d
| Dutv u, Dutv v when tv_equal u v ->
()
|(Dapp (s1,dl1,_), Dapp (s2,dl2,_)
| Dpur (s1,dl1), Dpur (s2,dl2)) when its_equal s1 s2 ->
| Dapp (s1,dl1,_), Dapp (s2,dl2,_) when its_equal s1 s2 ->
List.iter2 dity_unify dl1 dl2
| _ -> raise Exit
......@@ -124,7 +114,6 @@ let rec dity_refresh ht = function
let r = dreg_fresh (dity_refresh ht d) in
Htv.add ht v r; r end
| 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,
List.map (dity_refresh ht) rl)
| Dvar {contents = Dval d} -> dity_refresh (Htv.create 3) d
......@@ -155,8 +144,6 @@ let rec reunify d1 d2 = match d1,d2 with
| Dapp (_,dl1,rl1), Dapp (_,dl2,rl2) ->
List.iter2 reunify dl1 dl2;
List.iter2 reunify rl1 rl2
| Dpur (_,dl1), Dpur (_,dl2) ->
List.iter2 reunify dl1 dl2
| _ -> assert false
let reunify_regions () =
......@@ -204,6 +191,8 @@ let rec print_dity pri fmt = function
Format.fprintf fmt (protect_on (pri > 1) "%a@ @@%s")
(print_dity 0) d (Ident.id_unique rprinter v.tv_name)
| 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")
(print_dity 0) d (Ident.id_unique rprinter (reg_of_ity ity).reg_name)
| Dapp (s,[t1;t2],[]) when its_equal s its_func ->
......@@ -215,9 +204,11 @@ let rec print_dity pri fmt = function
Format.fprintf fmt (protect_on (pri > 1) "%a%a%a")
Pretty.print_ts s.its_ts (print_args (print_dity 2)) tl
(print_regs (print_dity 0)) rl
(*
| Dpur (s,tl) ->
Format.fprintf fmt (protect_on (pri > 1 && tl <> []) "{%a}%a")
Pretty.print_ts s.its_ts (print_args (print_dity 2)) tl
*)
let print_dity fmt d = print_dity 0 fmt d
......@@ -231,7 +222,6 @@ let specialize_scheme tvs (argl,res) =
| Dvar {contents = Dtvs v} | Dutv v as d -> get_tv 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)
| Dpur (s,dl) -> Dpur (s, List.map spec_dity dl)
and get_tv v d = try Htv.find hv v with Not_found ->
let nd = dity_fresh () in
(* can't return d, might differ in regions *)
......@@ -245,14 +235,13 @@ let specialize_scheme tvs (argl,res) =
let spec_ity hv hr frz ity =
let rec dity ity = match ity.ity_node with
| Ityreg r -> dreg r
| Ityvar v -> if Mtv.mem v frz.isb_tv then Dutv v else get_tv v
| Ityapp (s,tl,rl) -> Dapp (s, List.map dity tl, List.map dreg rl)
| Itypur (s,tl) -> Dpur (s, List.map dity tl)
| 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 dity rl)
and get_tv v = try Htv.find hv v with Not_found ->
let nd = dity_fresh () in Htv.add hv v nd; nd
and dreg reg = try Hreg.find hr reg with Not_found ->
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
Durg (ity_reg reg, d) else dreg_fresh d in
Hreg.add hr reg r; r in
......@@ -272,7 +261,7 @@ let specialize_rs {rs_cty = cty} =
let specialize_ls {ls_args = args; ls_value = res} =
let hv = Htv.create 3 and hr = Hreg.create 3 in
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
let spec ty = spec_ity hv hr isb_empty (ity ty) in
List.map spec args, Opt.fold (Util.const spec) dity_bool res
......@@ -390,7 +379,7 @@ let freeze_dvty frozen (argl,res) =
| Dvar { contents = Dval d } -> add l d
| Dvar { contents = Dtvs _ } 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
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 = Dtvs v }
| 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
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) =
| Dvar { contents = Dval d } -> is_explicit d
| Dvar { contents = Dtvs _ } -> false
| 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
then denv_add_rec_poly denv frozen0 id dvty
else denv_add_rec_mono denv id dvty
......@@ -848,7 +837,7 @@ let env_empty = {
exception UnboundLabel of string
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
(* if v is top-level, both ov and pv are None.
If v is local, ov and pv must be equal to v.
......@@ -925,6 +914,7 @@ let cty_of_spec env bl dsp dity =
let dsp = get_later env dsp ity in
let _, eff = effect_of_dspec dsp 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 q = create_post ity dsp.ds_post 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
| DEapp (de1,de2) -> down de1 (expr uloc env de2 :: el)
| DEvar (n,_) -> app (ext_c_sym (get_rs env n)) 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"
| DEls s -> ext_c_pur s el argl res
| _ -> app (cexp uloc env ghost de) el in
......
......@@ -166,7 +166,8 @@ let create_projection s v =
let id = id_clone v.pv_vs.vs_name in
let eff = eff_ghostify v.pv_ghost eff_empty 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 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
......@@ -191,12 +192,16 @@ let create_constructor ~constr id s fl =
end else if constr < 1 then raise exn;
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 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 ls = create_fsymbol ~constr id argl ty 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 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
let rs_of_ls ls =
......@@ -442,7 +447,7 @@ let e_ghostify gh ({e_effect = eff} as e) =
let c_ghostify gh ({c_cty = cty} as c) =
if cty.cty_effect.eff_ghost || not gh then c else
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 *)
......@@ -645,8 +650,8 @@ let e_exec ({c_cty = cty} as c) = match cty.cty_args with
| _::_ as al ->
check_effects cty; check_state cty;
(* no need to check eff_covers since we are completely pure *)
if List.exists (fun a -> not a.pv_ity.ity_pure) al ||
not cty.cty_result.ity_pure then Loc.errorm "This function \
if List.exists (fun a -> not a.pv_ity.ity_imm) al ||
not cty.cty_result.ity_imm then Loc.errorm "This function \
has mutable type signature, it cannot be used as pure";
let ghost = List.exists (fun a -> a.pv_ghost) al in
let effect = eff_bind (Spv.of_list al) cty.cty_effect in
......@@ -667,8 +672,8 @@ let c_app s vl ityl ity =
mk_cexp (Capp (s,vl)) (cty_apply s.rs_cty vl ityl ity)
let c_pur s vl ityl ity =
if not ity.ity_pure then invalid_arg "Expr.c_pur";
let v_args = List.map (create_pvsymbol (id_fresh "u")) ityl in
if not (ity_pure ity) then invalid_arg "Expr.c_pur";
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 res = Opt.map (fun _ -> ty_of_ity ity) s.ls_value in
let q = make_post (t_app s t_args res) in
......@@ -871,7 +876,7 @@ let e_raise xs e ity =
(* snapshots, assertions, "any" *)
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
mk_expr (Epure t) ity eff
......@@ -1099,10 +1104,12 @@ let debug_print_locs = Debug.register_info_flag "print_locs"
~desc:"Print@ locations@ of@ identifiers@ and@ expressions."
let ambig_cty c =
let sarg = List.fold_left (fun s v ->
ity_freeze s v.pv_ity) isb_empty c.cty_args in
let freeze_pv v s = ity_freeze s v.pv_ity 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
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 sarg = List.fold_left ty_freevars Stv.empty s.ls_args in
......
This diff is collapsed.
......@@ -16,14 +16,15 @@ open Term
(** {2 Individual types (first-order types without effects)} *)
type itysymbol = private {
its_ts : tysymbol; (** pure "snapshot" type symbol *)
its_privmut : bool; (** private mutable record type *)
its_ts : tysymbol; (** logical type symbol *)
its_privmut : bool; (** private mutable type *)
its_mfields : pvsymbol list; (** mutable record fields *)
its_regions : region list; (** mutable shareable components *)
its_arg_imm : bool list; (** non-updatable type parameters *)
its_regions : region list; (** shareable components *)
its_arg_imm : bool list; (** non-updatable parameters *)
its_arg_exp : bool list; (** exposed type parameters *)
its_arg_vis : bool list; (** non-ghost 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_frz : bool list; (** irreplaceable shareable components *)
its_def : ity option; (** type alias *)
......@@ -31,25 +32,23 @@ type itysymbol = private {
and ity = private {
ity_node : ity_node;
ity_pure : bool;
ity_imm : bool;
ity_tag : Weakhtbl.tag;
}
and ity_node = private
| Ityreg of region
(** record with mutable fields and shareable components *)
| Ityapp of itysymbol * ity list * region list
(** immutable type or algebraic type with shareable components *)
| Itypur of itysymbol * ity list
(** pure snapshot of a mutable type *)
| Ityvar of tvsymbol
(** type variable *)
| Ityapp of itysymbol * ity list * ity list
(** immutable type with shareable components *)
| Ityvar of tvsymbol * bool
(** type variable and its purity status *)
and region = private {
reg_name : ident;
reg_its : itysymbol;
reg_args : ity list;
reg_regs : region list;
reg_regs : ity list;
}
and pvsymbol = private {
......@@ -120,11 +119,22 @@ val create_itysymbol_rich :
val restore_its : tysymbol -> itysymbol
(** raises [Not_found] if the argument is not a [its_ts] *)
val its_mutable : itysymbol -> bool
(** [its_mutable s] checks if [s] is a mutable record or an alias for one *)
(* {2 Basic properties} *)
val its_impure : itysymbol -> bool
(** [its_impure s] checks if [s] is mutable or has mutable components *)
val its_immutable : itysymbol -> bool
(** 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} *)
......@@ -132,38 +142,44 @@ exception BadItyArity of itysymbol * int
exception BadRegArity of itysymbol * int
exception NonUpdatable of itysymbol * ity
val create_region : preid -> itysymbol -> ity list -> region list -> region
(** the type symbol must be mutable, aliases are allowed *)
val create_region : preid -> itysymbol -> ity list -> ity list -> region
(** [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_var : tvsymbol -> ity
val ity_app : itysymbol -> ity list -> ity list -> 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
(** [ity_pur s tl] creates
- an [Itypur] snapshot type if [its_impure s] is true
- an [Ityapp (s,tl,[])] type otherwise *)
val ity_app_pure : itysymbol -> ity list -> ity list -> ity
(** [ity_app s tl rl] creates an [Ityapp] type.
If [rl] is empty, pure snapshots are substituted when needed. *)
val ity_app : itysymbol -> ity list -> region list -> 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_reg : region -> ity
val ity_app_fresh : itysymbol -> ity list -> ity
(** [ity_app_fresh] creates fresh regions where needed *)
val ity_var : tvsymbol -> ity
val ty_of_ity : ity -> ty
(** all aliases expanded, all regions removed *)
val ity_var_pure : tvsymbol -> ity
val ity_purify : ity -> ity
(** replaces regions with pure snapshots and variables with pure variables. *)
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
(** snapshot type *)
val ity_of_ty_pure : ty -> ity
(** 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} *)
val ity_fold : ('a -> ity -> 'a) -> ('a -> region -> 'a) -> 'a -> ity -> 'a
val reg_fold : ('a -> ity -> 'a) -> ('a -> region -> 'a) -> 'a -> region -> 'a
val ity_fold : ('a -> ity -> 'a) -> 'a -> ity -> 'a
val reg_fold : ('a -> ity -> 'a) -> 'a -> region -> 'a
(** {2 Traversal functions on type symbols} *)
......@@ -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 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 reg_freevars : Stv.t -> region -> Stv.t
val ity_v_occurs : tvsymbol -> ity -> 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 reg_r_occurs : region -> region -> bool
val ity_r_stale : Sreg.t -> 'a Mreg.t -> ity -> bool
val reg_r_stale : Sreg.t -> 'a Mreg.t -> region -> bool
val ity_closed : ity -> bool
(** {2 Utility functions on exposed regions} *)
(* 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_v_visible : Stv.t -> ity -> Stv.t
val ity_r_stale : Sreg.t -> 'a Mreg.t -> ity -> bool
val reg_r_stale : Sreg.t -> 'a Mreg.t -> region -> bool
(** {2 Built-in types} *)
......@@ -225,19 +240,21 @@ val ity_tuple : ity list -> ity
(** {2 Type matching and instantiation} *)
type ity_subst = private {
isb_tv : ity Mtv.t;
isb_reg : region Mreg.t;
isb_var : ity Mtv.t;
isb_pur : ity Mtv.t;
isb_reg : ity Mreg.t;
}
exception TypeMismatch of ity * ity * ity_subst
exception ImpureType of tvsymbol * ity
val isb_empty : 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_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 reg_freeze : ity_subst -> region -> ity_subst (* self-match *)
......@@ -246,7 +263,7 @@ val ity_equal_check : ity -> ity -> unit
val reg_equal_check : region -> region -> unit
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} *)
......@@ -279,6 +296,7 @@ val create_xsymbol : preid -> ity -> xsymbol
(** {2 Effects} *)
exception IllegalSnapshot of ity
exception IllegalAlias of region
exception AssignPrivate of region
exception StaleVariable of pvsymbol * region
......@@ -317,7 +335,7 @@ val eff_read_single_post : effect -> pvsymbol -> effect
val eff_bind_single : pvsymbol -> effect -> effect
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 *)
val eff_raise : effect -> xsymbol -> effect
val eff_catch : effect -> xsymbol -> effect
......@@ -360,7 +378,7 @@ val create_cty : pvsymbol list ->
Fresh regions in [result] are reset. Every type variable in [pre],
[post], and [xpost] must come from [cty_reads], [args] or [result].
[oldies] maps ghost pure snapshots of the parameters and external
reads to the original pvsymbols: these snaphosts are removed from
reads to the original pvsymbols: these snapshots are removed from
[cty_effect.eff_reads] and replaced with the originals. *)
val cty_apply : cty -> pvsymbol list -> ity list -> ity -> cty
......
......@@ -40,7 +40,7 @@ let check_field stv f =
let ftv = ity_freevars Stv.empty f.pv_ity in
if not (Stv.subset ftv stv) then Loc.error ?loc
(UnboundTypeVar (Stv.choose (Stv.diff ftv stv)));
if not f.pv_ity.ity_pure then Loc.error ?loc
if not f.pv_ity.ity_imm then Loc.error ?loc
(ImpureField f.pv_ity)
let check_invariant stv svs p =
......@@ -61,13 +61,18 @@ let check_pure_its s = not s.its_privmut &&
s.its_def = None
let create_semi_constructor id s fl pjl invl =
let ity = ity_app s (List.map ity_var s.its_ts.ts_args) s.its_regions in
let tvl = List.map ity_var s.its_ts.ts_args in
let rgl = List.map ity_reg s.its_regions in
let ity = ity_app s tvl rgl in
let res = create_vsymbol (id_fresh "result") (ty_of_ity ity) in
let t = t_var res in
let get_pj p = match p.rs_logic with RLls s -> s | _ -> assert false in
let mk_q {pv_vs = v} p = t_equ (fs_app (get_pj p) [t] v.vs_ty) (t_var v) in
let q = create_post res (t_and_simp_l (List.map2 mk_q fl pjl)) in
let c = create_cty fl invl [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 invl [q] Mexn.empty Mpv.empty eff ity in
create_rsymbol id c
let create_flat_record_decl id args priv mut fldl invl =
......@@ -458,7 +463,7 @@ let create_let_decl ld =
let create_exn_decl xs =
if not (ity_closed xs.xs_ity) then Loc.errorm ?loc:xs.xs_name.id_loc
"Top-level exception %a has a polymorphic type" print_xs xs;
if not xs.xs_ity.ity_pure then Loc.errorm ?loc:xs.xs_name.id_loc
if not xs.xs_ity.ity_imm then Loc.errorm ?loc:xs.xs_name.id_loc
"The type of top-level exception %a has mutable components" print_xs xs;
mk_decl (PDexn xs) []
......@@ -551,8 +556,8 @@ let print_its_defn fst fmt itd =
print_ity f.rs_cty.cty_result in
let is_big ity = match ity.ity_node with
| Ityreg {reg_args = []; reg_regs = []}
| Ityapp (_,[],[]) | Itypur (_,[]) | Ityvar _ -> false
| Itypur (s,_) when is_ts_tuple s.its_ts -> false
| Ityapp (_,[],[]) | Ityvar _ -> false
| Ityapp (s,_,[]) when is_ts_tuple s.its_ts -> false
| _ -> true in
let print_proj mf fmt f = match Mpv.find_opt f mf with
| Some f -> fprintf fmt "@ (%a)" print_field f
......
......@@ -223,11 +223,10 @@ let count_regions {muc_known = kn} {pv_ity = ity} mr =
let add_reg r mr = Mreg.change (fun n -> Some (n <> None)) r mr in
let meet mr1 mr2 = Mreg.union (fun _ x y -> Some (x || y)) mr1 mr2 in
let join mr1 mr2 = Mreg.union (fun _ _ _ -> Some true) mr1 mr2 in
let rec down mr ity = if ity.ity_pure then mr else
let rec down mr ity = if ity.ity_imm then mr else
match ity.ity_node with
| Ityreg r -> fields (add_reg r mr) r.reg_its r.reg_args r.reg_regs
| Ityapp (s,tl,rl) -> fields mr s tl rl
| Itypur (s,tl) -> fields mr s tl []
| Ityvar _ -> assert false
and fields mr s tl rl = if s.its_privmut then mr else
let add_arg isb v ity = ity_match isb (ity_var v) ity in
......@@ -407,20 +406,13 @@ let rec clone_ity cl ity = match ity.ity_node with
ity_reg (clone_reg cl r)
| Ityapp (s, tl, rl) ->
let tl = List.map (clone_ity cl) tl in
let rl = List.map (clone_reg cl) rl in
let rl = List.map (clone_ity cl) rl in
begin match Mts.find_opt s.its_ts cl.ts_table with
| Some its -> ity_app its tl rl
| None -> begin match Mts.find_opt s.its_ts cl.ty_table with
| Some its -> ity_app_pure its tl rl
| None -> (* creative indentation *)
begin match Mts.find_opt s.its_ts cl.ty_table with
| Some ity -> ity_full_inst (its_match_regs s tl rl) ity
| None -> ity_app s tl rl
end end
| Itypur (s, tl) ->
let tl = List.map (clone_ity cl) tl in
begin match Mts.find_opt s.its_ts cl.ts_table with
| Some its -> ity_pur its tl
| None -> begin match Mts.find_opt s.its_ts cl.ty_table with
| Some ity -> ity_full_inst (its_match_args s tl) (ity_purify ity)
| None -> ity_pur s tl
| None -> ity_app_pure s tl rl
end end
| Ityvar _ -> ity
......@@ -432,15 +424,16 @@ and clone_reg cl reg =
descending into a let_defn. *)
try Mreg.find reg cl.rn_table with Not_found ->
let tl = List.map (clone_ity cl) reg.reg_args in
let rl = List.map (clone_reg cl) reg.reg_regs in
let rl = List.map (clone_ity cl) reg.reg_regs in
let r = match Mts.find_opt reg.reg_its.its_ts cl.ts_table with
| Some its ->
create_region (id_clone reg.reg_name) its tl rl
| None -> begin match Mts.find_opt reg.reg_its.its_ts cl.ty_table with
| 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 (reg_full_inst sbs) r.reg_regs 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 ->
......@@ -484,22 +477,18 @@ let clone_ls inst cl ls =
ls'
let cl_init_ty cl ({ts_name = id} as ts) ty =
let rec restore_ity ty = match ty.ty_node with
| Tyapp (s,tl) ->
ity_app_fresh (restore_its s) (List.map restore_ity tl)
| Tyvar v -> ity_var v in
let its = restore_its ts and ity = restore_ity ty in
let its = restore_its ts and ity = ity_of_ty ty in
if not (Sid.mem id cl.cl_local) then raise (NonLocal id);
let stv = Stv.of_list ts.ts_args in
if not (Stv.subset (ity_freevars Stv.empty ity) stv) ||
its_impure its || not ity.ity_pure then raise (BadInstance id);
if not (Stv.subset (ity_freevars Stv.empty ity) stv &&
its_pure its && ity_immutable ity) then raise (BadInstance id);
cl.ty_table <- Mts.add ts ity cl.ty_table
let cl_init_ts cl ({ts_name = id} as ts) ts' =
let its = restore_its ts and its' = restore_its ts' in
if not (Sid.mem id cl.cl_local) then raise (NonLocal id);
if List.length ts.ts_args <> List.length ts'.ts_args ||
its_impure its || its_impure its' then raise (BadInstance id);
if not (List.length ts.ts_args = List.length ts'.ts_args &&
its_pure its && its_pure its') then raise (BadInstance id);
cl.ts_table <- Mts.add its.its_ts its' cl.ts_table
let cl_init_ls cl ({ls_name = id} as ls) ls' =
......@@ -638,7 +627,7 @@ let clone_type_decl inst cl tdl =
if cloned then raise (CannotInstantiate id);
let mfld = Spv.of_list s.its_mfields in
let priv = d.itd_constructors = [] in
let mut = its_mutable s in
let mut = not (its_immutable s) in
let pjl = List.map (fun fd -> Opt.get fd.rs_field) d.itd_fields in
let fdl = List.map (fun v -> Spv.mem v mfld, conv_pj v) pjl in
let inv =
......@@ -654,7 +643,7 @@ let clone_type_decl inst cl tdl =
and conv_ity alg ity =
let rec down ity = match ity.ity_node with
| Ityreg {reg_its = s; reg_args = tl}
| Ityapp (s,tl,_) | Itypur (s,tl) ->
| Ityapp (s,tl,_) ->
if Sits.mem s alg then begin
if not (Mts.mem s.its_ts cl.ts_table) then
let id = id_clone s.its_ts.ts_name in
......@@ -891,7 +880,9 @@ let clone_pdecl inst cl uc d = match d.pd_node with
let frz = Spv.fold (fun v isb ->
if Sid.mem v.pv_vs.vs_name cl.cl_local then isb
else ity_freeze isb v.pv_ity) reads isb_empty in
cl.rn_table <- Mreg.set_union cl.rn_table frz.isb_reg;
let frz = Mreg.map (fun ity -> match ity.ity_node with
| Ityreg r -> r | _ -> assert false) frz.isb_reg in
cl.rn_table <- Mreg.set_union cl.rn_table frz;
let sm, ld = clone_let_defn cl (sm_of_cl cl) ld in
cl.pv_table <- sm.sm_pv; cl.rs_table <- sm.sm_rs;
add_pdecl ~vc:false uc (create_let_decl ld)
......
......@@ -135,7 +135,7 @@ let ity_of_pty muc pty =
| PTtyapp (q, tyl) ->
let s = find_itysymbol muc q in
let tyl = List.map get_ity tyl in
Loc.try2 ~loc:(qloc q) ity_app_fresh s tyl
Loc.try3 ~loc:(qloc q) ity_app s tyl []