Generative labels

bin/repl.ml

@@ -185,7 +185,7 @@ let rec directives : (string * ((Context.t -> string list -> Context.t) * string
                   else (Module_hacks.Name.prettify name)
                 in
                 Printf.fprintf stderr " %-16s : %s\n"
-                  name ty)
+                  name ty) (* TODO(dhil): should really "prettify" ty here too as it may contain unique labels that have been expanded. *)
             nenv ();
           context),
          "display the current value environment");

core/buildTables.ml

@@ -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 (Label.Map.empty, None))) in ()
 
   let program tyenv bound_vars cont_vars e =
     let _ = (new visitor tyenv bound_vars cont_vars)#computation e in ()

core/channelVarUtils.ml

@@ -11,9 +11,9 @@ let variables_in_computation comp =
   let variable_set = ref IntSet.empty in
   let add_variable var =
     variable_set := (IntSet.add var !variable_set) in
-  let rec traverse_stringmap : 'a . ('a -> unit) -> 'a stringmap -> unit =
+  let rec traverse_name_map : 'a . ('a -> unit) -> 'a name_map -> unit =
     fun proj_fn smap -> (* (proj_fn: 'a . 'a -> 'b) (smap: 'a stringmap) : unit = *)
-      StringMap.fold (fun _ v _ -> proj_fn v) smap ()
+      Label.Map.fold (fun _ v _ -> proj_fn v) smap ()
   and traverse_value = function
     | Variable v -> add_variable v
     | Closure (_, _, value)
@@ -24,13 +24,13 @@ let variables_in_computation comp =
     | Coerce (value, _)
     | Erase (_, value) -> traverse_value value
     | XmlNode (_, v_map, vs) ->
-        traverse_stringmap (traverse_value) v_map;
+        traverse_name_map (traverse_value) v_map;
         List.iter traverse_value vs
     | ApplyPure (v, vs) ->
         traverse_value v;
         List.iter traverse_value vs
     | Extend (v_map, v_opt) ->
-        traverse_stringmap (traverse_value) v_map;
+        traverse_name_map (traverse_value) v_map;
         begin match v_opt with | Some v -> traverse_value v | None -> () end
     | Constant _ -> ()
   and traverse_tail_computation = function
@@ -42,7 +42,7 @@ let variables_in_computation comp =
         traverse_value v; List.iter traverse_computation [c1 ; c2]
     | Case (scrutinee, cases, case_opt) ->
         traverse_value scrutinee;
-        traverse_stringmap (fun (_, c) -> traverse_computation c) cases;
+        traverse_name_map (fun (_, c) -> traverse_computation c) cases;
         OptionUtils.opt_iter (fun (_, c) -> traverse_computation c) case_opt
   and traverse_fundef {fn_binder = bnd; _} =
     let fun_var = Var.var_of_binder bnd in
@@ -109,7 +109,7 @@ let variables_in_computation comp =
     | DoOperation (_, vs, _) -> List.iter (traverse_value) vs
     | Choice (v, clauses) ->
         traverse_value v;
-        traverse_stringmap (fun (_, c) ->
+        traverse_name_map (fun (_, c) ->
           traverse_computation c) clauses
     | Lens (value, _)
     | LensSerial { lens = value; _ }
@@ -124,7 +124,7 @@ let variables_in_computation comp =
   and traverse_clause (_, _, c) = traverse_computation c
   and traverse_handler (h: Ir.handler) =
     traverse_computation (h.ih_comp);
-    traverse_stringmap (traverse_clause) h.ih_cases;
+    traverse_name_map (traverse_clause) h.ih_cases;
     traverse_computation (snd h.ih_return)
   in
   traverse_computation comp;

core/closures.ml

@@ -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)
+                               Label.Map.add zname zv fields)
                             zs
-                            StringMap.empty, None))
+                            Label.Map.empty, None))
 
   class visitor tenv fenv =
     object (o : 'self) inherit IrTraversals.Transform.visitor(tenv) as super
@@ -456,7 +456,7 @@ struct
             if IntSet.mem x cvars then
               (* We cannot return t as the type of the result here. If x refers to a hoisted function that was generalised, then
                  t has additional quantifiers that are not present in the corresponding type of projecting x from parent_env *)
-              let projected_t = TypeUtils.project_type (string_of_int x) (thd3 (o#var parent_env)) in
+              let projected_t = TypeUtils.project_type (Label.of_int x) (thd3 (o#var parent_env)) in
               Project (string_of_int x, Variable parent_env), projected_t
             else if IntMap.mem x fenv then
               let zs = (IntMap.find x fenv).termvars in
@@ -476,7 +476,7 @@ struct
                       (fun b ->
                         let z = Var.var_of_binder b in
                         let v = fst (var_val z) in
-                        (string_of_int z, v))
+                        (Label.of_int z, v))
                       zs
                   in
                   close x zs tyargs, overall_type
@@ -534,14 +534,14 @@ struct
             | [], [] -> o, None
             | _ ->
               let zt =
-                Types.make_record_type
+                Types.(make_record_type
                   (List.fold_left
                      (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
-                     zs)
+                       Label.Map.add (Label.of_int x) xt fields)
+                     Label.Map.empty
+                     zs))
               in
               (* fresh variable for the closure environment *)
               let zb = Var.(fresh_binder (make_local_info (zt, "env_" ^ string_of_int f))) in
@@ -610,14 +610,14 @@ struct
                      | [], [] -> o, None
                      | _ ->
                        let zt =
-                         Types.make_record_type
+                         Types.(make_record_type
                            (List.fold_left
                               (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
-                              zs)
+                                Label.Map.add (Label.of_int x) xt fields)
+                              Label.Map.empty
+                              zs))
                        in
                        (* fresh variable for the closure environment *)
                        let zb = Var.(fresh_binder (make_local_info (zt, "env_" ^ string_of_int f))) in

core/commonTypes.ml

@@ -282,11 +282,6 @@ module Name = struct
     [@@deriving show]
 end
 
-module Label = struct
-  type t = string
-    [@@deriving show]
-end
-
 module ForeignLanguage = struct
   type t =
     | JavaScript