Skip to content

Sorting record members first on the length of the key #1211

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Sorting record members first on the length of the key #1211

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion core/buildTables.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -255,7 +255,7 @@ struct

let bindings tyenv bound_vars cont_vars bs =
let o = new visitor tyenv bound_vars cont_vars in
let _ = o#computation (bs, Return (Extend (StringMap.empty, None))) in ()
let _ = o#computation (bs, Return (Extend (Types.FieldEnv.empty, None))) in ()

let program tyenv bound_vars cont_vars e =
let _ = (new visitor tyenv bound_vars cont_vars)#computation e in ()
Expand Down
5 changes: 4 additions & 1 deletion core/channelVarUtils.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,6 +14,9 @@ let variables_in_computation comp =
let rec traverse_stringmap : 'a . ('a -> unit) -> 'a stringmap -> unit =
fun proj_fn smap -> (* (proj_fn: 'a . 'a -> 'b) (smap: 'a stringmap) : unit = *)
StringMap.fold (fun _ v _ -> proj_fn v) smap ()
and traverse_ststringmap : 'a . ('a -> unit) -> 'a st_name_map -> unit =
fun proj_fn smap -> (* (proj_fn: 'a . 'a -> 'b) (smap: 'a st_name_map) : unit = *)
Types.FieldEnv.fold (fun _ v _ -> proj_fn v) smap ()
and traverse_value = function
| Variable v -> add_variable v
| Closure (_, _, value)
Expand All @@ -30,7 +33,7 @@ let variables_in_computation comp =
traverse_value v;
List.iter traverse_value vs
| Extend (v_map, v_opt) ->
traverse_stringmap (traverse_value) v_map;
traverse_ststringmap (traverse_value) v_map;
begin match v_opt with | Some v -> traverse_value v | None -> () end
| Constant _ -> ()
and traverse_tail_computation = function
Expand Down
12 changes: 6 additions & 6 deletions core/closures.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -428,9 +428,9 @@ struct
let close f zs tyargs =
Closure (f, tyargs, Extend (List.fold_right
(fun (zname, zv) fields ->
StringMap.add zname zv fields)
Types.FieldEnv.add zname zv fields)
zs
StringMap.empty, None))
Types.FieldEnv.empty, None))

class visitor tenv fenv =
object (o : 'self) inherit IrTraversals.Transform.visitor(tenv) as super
Expand Down Expand Up @@ -539,8 +539,8 @@ struct
(fun fields b ->
let x = Var.var_of_binder b in
let xt = Var.type_of_binder b in
StringMap.add (string_of_int x) xt fields)
StringMap.empty
Types.FieldEnv.add (string_of_int x) xt fields)
Types.FieldEnv.empty
zs)
in
(* fresh variable for the closure environment *)
Expand Down Expand Up @@ -615,8 +615,8 @@ struct
(fun fields b ->
let x = Var.var_of_binder b in
let xt = Var.type_of_binder b in
StringMap.add (string_of_int x) xt fields)
StringMap.empty
Types.FieldEnv.add (string_of_int x) xt fields)
Types.FieldEnv.empty
zs)
in
(* fresh variable for the closure environment *)
Expand Down
42 changes: 21 additions & 21 deletions core/compilePatterns.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -33,7 +33,7 @@ struct
| Variant of Name.t * t
| Operation of Name.t * t list * t
| Negative of StringSet.t
| Record of t StringMap.t * t option
| Record of t Types.FieldEnv.t * t option
| Constant of Constant.t
| Variable of binder
| As of binder * t
Expand Down Expand Up @@ -144,9 +144,9 @@ let rec desugar_pattern : Types.row -> Sugartypes.Pattern.with_pos -> Pattern.t
List.fold_right
(fun (name, p) (bs, env) ->
let p, env' = desugar_pattern p in
StringMap.add name p bs, env ++ env')
Types.FieldEnv.add name p bs, env ++ env')
bs
(StringMap.empty, empty) in
(Types.FieldEnv.empty, empty) in
let p, env =
match p with
| None -> None, env
Expand Down Expand Up @@ -297,7 +297,7 @@ let let_pattern : raw_env -> Pattern.t -> value * Types.datatype -> computation
| None -> body
| Some p ->
let names =
StringMap.fold
Types.FieldEnv.fold
(fun name _ names ->
StringSet.add name names)
fields
Expand All @@ -306,7 +306,7 @@ let let_pattern : raw_env -> Pattern.t -> value * Types.datatype -> computation
lp rt p (Erase (names, value)) body
(* lp rt p (`Coerce (value, rt)) body *)
in
StringMap.fold
Types.FieldEnv.fold
(fun name p body ->
let t' = (TypeUtils.project_type name t) in
(lp t' p (Project (name, value)) body))
Expand Down Expand Up @@ -444,24 +444,24 @@ let arrange_constant_clauses
This function flattens all the record clauses.
*)
let arrange_record_clauses
: clause list -> (annotated_pattern StringMap.t * annotated_pattern option * annotated_clause) list =
: clause list -> (annotated_pattern Types.FieldEnv.t * annotated_pattern option * annotated_clause) list =
fun clauses ->
let rec flatten =
function
| Pattern.Record (bs, None) ->
bs, None
| Pattern.Record (bs, Some p) ->
let bs', p' = flatten p in
StringMap.union_disjoint bs bs', p'
Types.FieldEnv.union_disjoint bs bs', p'
| p ->
StringMap.empty, Some p
Types.FieldEnv.empty, Some p
in
List.fold_right
(fun (ps, body) xs ->
match ps with
| (annotation, p)::ps ->
let bs, p = flatten p in
let bs = StringMap.map reduce_pattern bs in
let bs = Types.FieldEnv.map reduce_pattern bs in
let p = opt_map reduce_pattern p in
(bs, p, (annotation, (ps, body)))::xs
| _ -> assert false
Expand Down Expand Up @@ -810,15 +810,15 @@ and match_constant
| _ -> assert false

and match_record
: var list -> (annotated_pattern StringMap.t * annotated_pattern option * annotated_clause) list ->
: var list -> (annotated_pattern Types.FieldEnv.t * annotated_pattern option * annotated_clause) list ->
bound_computation -> var -> bound_computation =
fun vars xs def var env ->
let t = lookup_type var env in

let names =
List.fold_right
(fun (bs, _, _) names ->
StringMap.fold (fun name _ names -> StringSet.add name names) bs names) xs StringSet.empty in
Types.FieldEnv.fold (fun name _ names -> StringSet.add name names) bs names) xs StringSet.empty in
let all_closed = List.for_all (function
| (_, None, _) -> true
| (_, Some _, _) -> false) xs in
Expand All @@ -838,25 +838,25 @@ and match_record
let rps, fields =
StringSet.fold
(fun name (ps, fields) ->
if StringMap.mem name bs then
StringMap.find name bs :: ps, fields
if Types.FieldEnv.mem name bs then
Types.FieldEnv.find name bs :: ps, fields
else
if closed then
([], Pattern.Any)::ps, fields
else
let xt = TypeUtils.project_type name t in
let xb, x = Var.fresh_var_of_type xt in
([], Pattern.Variable xb)::ps, StringMap.add name (Variable x) fields)
([], Pattern.Variable xb)::ps, Types.FieldEnv.add name (Variable x) fields)
names
([], StringMap.empty) in
([], Types.FieldEnv.empty) in
let rps, body =
if all_closed then
rps, body
else if closed then
([], Pattern.Any)::List.rev rps, body
else
let original_names =
StringMap.fold
Types.FieldEnv.fold
(fun name _ names ->
StringSet.add name names)
bs
Expand Down Expand Up @@ -988,7 +988,7 @@ let compile_handle_cases
let variant_type =
let (fields,_,_) = comp_eff |> TypeUtils.extract_row_parts in
let fields' =
StringMap.filter
Types.FieldEnv.filter
(fun _ ->
function
| Types.Present _ -> true
Expand All @@ -998,9 +998,9 @@ let compile_handle_cases
let rec extract t = match TypeUtils.concrete_type t with
| Types.Operation (domain, _, _) ->
let (fields, _, _) = TypeUtils.extract_row domain |> TypeUtils.extract_row_parts in
let arity = StringMap.size fields in
let arity = Types.FieldEnv.size fields in
if arity = 1 then
match StringMap.find "1" fields with
match Types.FieldEnv.find "1" fields with
| Types.Present t -> t
| _ -> assert false
else
Expand All @@ -1009,7 +1009,7 @@ let compile_handle_cases
| _ -> Types.unit_type (* nullary operation *)
in
let fields'' =
StringMap.map
Types.FieldEnv.map
(function
| Types.Present t ->
extract t
Expand All @@ -1033,7 +1033,7 @@ let compile_handle_cases
let fields =
List.mapi (fun i p -> (string_of_int (i+1), p)) ps
in
Pattern.Record (StringMap.from_alist fields, None)
Pattern.Record (Types.FieldEnv.from_alist fields, None)
in
Pattern.Variant (name, packaged_args)
| _ -> assert false
Expand Down
5 changes: 2 additions & 3 deletions core/desugarCP.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -115,10 +115,10 @@ object (o : 'self_type)
let (eff_fields, eff_row, eff_closed) =
Types.flatten_row o#lookup_effects
|> TypeUtils.extract_row_parts in
let eff_fields = StringMap.remove wild_str eff_fields in
let eff_fields = Types.FieldEnv.remove wild_str eff_fields in
let eff_fields =
if Settings.get Basicsettings.Sessions.exceptions_enabled then
StringMap.remove Value.session_exception_operation eff_fields
Types.FieldEnv.remove Value.session_exception_operation eff_fields
else
eff_fields in

Expand Down Expand Up @@ -149,4 +149,3 @@ module Typeable
let name = "cp"
let obj env = (desugar_cp env : TransformSugar.transform :> Transform.Typeable.sugar_transformer)
end)

6 changes: 3 additions & 3 deletions core/desugarDatatypes.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -282,7 +282,7 @@ module Desugar = struct
| Closed -> Types.make_empty_closed_row ()
| Open srv ->
let rv = SugarTypeVar.get_resolved_row_exn srv in
Types.Row (StringMap.empty, rv, false)
Types.Row (Types.FieldEnv.empty, rv, false)
| Recursive (stv, r) ->
let mrv = SugarTypeVar.get_resolved_row_exn stv in

Expand All @@ -291,7 +291,7 @@ module Desugar = struct

(* Turn mrv into a proper recursive row *)
Unionfind.change mrv (Types.Recursive (var, sk, r));
Types.Row (StringMap.empty, mrv, false)
Types.Row (Types.FieldEnv.empty, mrv, false)

in
let fields = List.map (fun (k, p) -> (k, fieldspec alias_env p node)) fields in
Expand Down Expand Up @@ -335,7 +335,7 @@ module Desugar = struct
let write_row, needed_row =
match TypeUtils.concrete_type read_type with
| Record (Row (fields, _, _)) ->
StringMap.fold
Types.FieldEnv.fold
(fun label t (write, needed) ->
match lookup label constraints with
| Some cs ->
Expand Down
2 changes: 1 addition & 1 deletion core/desugarEffects.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -479,7 +479,7 @@ let gather_mutual_info (tycon_env : simple_tycon_env) =

let gather_operation_of_type tp
= let open Types in
let module FieldEnv = Utility.StringMap in
let module FieldEnv = Types.FieldEnv in
let is_effect_row_kind : Kind.t -> bool
= fun (primary, (_, restriction)) ->
primary = PrimaryKind.Row && restriction = Restriction.Effect
Expand Down
2 changes: 1 addition & 1 deletion core/desugarFuns.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -132,7 +132,7 @@ object (o : 'self_type)
let (fields, rho, _) = TypeUtils.extract_row_parts row in
let effb, row = fresh_row_quantifier default_effect_subkind in

let r = Record (Row (StringMap.add name (Present a) fields, rho, false)) in
let r = Record (Row (FieldEnv.add name (Present a) fields, rho, false)) in

let f = gensym ~prefix:"_fun_" () in
let x = gensym ~prefix:"_fun_" () in
Expand Down
2 changes: 1 addition & 1 deletion core/desugarProcesses.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -81,7 +81,7 @@ object (o : 'self_type)
Types.(remove_field hear (remove_field wild (Row (fieldenv, rho, false))))
in
begin
match StringMap.find Types.hear fieldenv with
match Types.FieldEnv.find Types.hear fieldenv with
| (Types.Present mbt) ->
o#phrasenode
(Switch (fn_appl "recv" [(Type, mbt); (Row, other_effects)] [],
Expand Down
10 changes: 5 additions & 5 deletions core/evalir.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -167,7 +167,7 @@ struct
opt_app (value env) (Lwt.return (`Record [])) r >>= fun res ->
match res with
| `Record fs ->
let fields = StringMap.bindings fields in
let fields = Types.FieldEnv.bindings fields in
LwtHelpers.foldr_lwt
(fun (label, v) (fs: (string * Value.t) list) ->
if List.mem_assoc label fs then
Expand Down Expand Up @@ -598,7 +598,7 @@ struct
let get_fields t =
match t with
| `Record fields ->
StringMap.to_list (fun name p -> (name, Types.Primitive p)) fields
Types.FieldEnv.to_list (fun name p -> (name, Types.Primitive p)) fields
| _ -> assert false
in
let execute_shredded_raw (q, t) =
Expand Down Expand Up @@ -783,7 +783,7 @@ struct
let r, _ = Types.unwrap_row (TypeUtils.extract_row t) in
TypeUtils.extract_row_parts r in
let fields =
StringMap.fold
Types.FieldEnv.fold
(fun name t fields ->
let open Types in
match t with
Expand Down Expand Up @@ -881,7 +881,7 @@ struct
| `Table { Value.Table.database = (db, _); name = table;
row = (fields, _, _); temporal_fields; _ } ->
let field_types =
StringMap.map
Types.FieldEnv.map
(function
| Types.Present t -> t
| _ -> assert false) fields
Expand Down Expand Up @@ -919,7 +919,7 @@ struct
match source with
| `Table { database = (db, _); name = table; row = (fields, _, _); temporal_fields; _ } ->
let field_types =
StringMap.map
Types.FieldEnv.map
(function
| Types.Present t -> t
| _ -> assert false) fields
Expand Down
6 changes: 3 additions & 3 deletions core/generalise.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -78,7 +78,7 @@ let rec get_type_args : gen_kind -> TypeVarSet.t -> datatype -> type_arg list =
(* Row *)
| Row (field_env, row_var, _) ->
let field_vars =
StringMap.fold
FieldEnv.fold
(fun _ field_spec vars ->
vars @ get_presence_type_args kind bound_vars field_spec
) field_env [] in
Expand Down Expand Up @@ -149,7 +149,7 @@ let rigidify_type_arg : type_arg -> unit =
| Type, Meta point -> rigidify_point point
| Presence, Meta point -> rigidify_point point
| Row, Row (fields, point, _dual) ->
assert (StringMap.is_empty fields);
assert (FieldEnv.is_empty fields);
rigidify_point point
(* HACK: probably shouldn't happen *)
| Row, Meta point -> rigidify_point point
Expand All @@ -169,7 +169,7 @@ let mono_type_args : type_arg -> unit =
| Type, Meta point -> check_sk point
| Presence, Meta point -> check_sk point
| Row, Row (fields, point, _dual) ->
assert (StringMap.is_empty fields);
assert (FieldEnv.is_empty fields);
check_sk point
(* HACK: probably shouldn't happen *)
| Row, Meta point -> check_sk point
Expand Down
Loading