Shift obj, type, param decls to have strata rather than effects.

6 files changed, 97 insertions, 59 deletions

diff --git a/src/boot/fe/ast.ml b/src/boot/fe/ast.ml
index b72c4935..ce9f9cc4 100644
--- a/src/boot/fe/ast.ml
+++ b/src/boot/fe/ast.ml
@@ -94,7 +94,7 @@ and ty =
   | TY_task
 
   | TY_native of opaque_id
-  | TY_param of (ty_param_idx * effect)
+  | TY_param of (ty_param_idx * stratum)
   | TY_named of name
   | TY_type
 
@@ -181,7 +181,7 @@ and ty_fn = (ty_sig * ty_fn_aux)
 
 and ty_obj_header = (slot array * constrs)
 
-and ty_obj = (effect * ((ident,ty_fn) Hashtbl.t))
+and ty_obj = (stratum * ((ident,ty_fn) Hashtbl.t))
 
 and check_calls = (lval * (atom array)) array
 
@@ -434,7 +434,7 @@ and fn =
 and obj =
     {
       obj_state: header_slots;
-      obj_effect: effect;
+      obj_stratum: stratum;
       obj_constrs: constrs;
       obj_fns: (ident,fn identified) Hashtbl.t;
       obj_drop: block option;
@@ -449,10 +449,10 @@ and obj =
  * even if it's a type that's bound by a quantifier in its environment.
  *)
 
-and ty_param = ident * (ty_param_idx * effect)
+and ty_param = ident * (ty_param_idx * stratum)
 
 and mod_item' =
-    MOD_ITEM_type of (effect * ty)
+    MOD_ITEM_type of (stratum * ty)
   | MOD_ITEM_tag of (header_slots * opaque_id * int)
   | MOD_ITEM_mod of (mod_view * mod_items)
   | MOD_ITEM_fn of fn
@@ -810,7 +810,7 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit =
       fmt_ident_tys ff entries;
       fmt ff "@]"
 
-  | TY_param (i, e) -> (fmt_effect_qual ff e;
+  | TY_param (i, s) -> (fmt_stratum_qual ff s;
                         fmt ff "<p#%d>" i)
   | TY_native oid -> fmt ff "<native#%d>" (int_of_opaque oid)
   | TY_named n -> fmt_name ff n
@@ -833,9 +833,9 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit =
 
   | TY_constrained ctrd -> fmt_constrained ff ctrd
 
-  | TY_obj (effect, fns) ->
+  | TY_obj (stratum, fns) ->
       fmt_obox ff;
-      fmt_effect_qual ff effect;
+      fmt_stratum_qual ff stratum;
       fmt ff "obj ";
       fmt_obr ff;
       Hashtbl.iter
@@ -1628,8 +1628,8 @@ and fmt_slice (ff:Format.formatter) (slice:slice) : unit =
 
 
 and fmt_decl_param (ff:Format.formatter) (param:ty_param) : unit =
-  let (ident, (i, e)) = param in
-  fmt_effect_qual ff e;
+  let (ident, (i, s)) = param in
+  fmt_stratum_qual ff s;
   fmt_ident ff ident;
   fmt ff "=<p#%d>" i
 
@@ -1683,7 +1683,7 @@ and fmt_obj
     (obj:obj)
     : unit =
   fmt_obox ff;
-  fmt_effect_qual ff obj.obj_effect;
+  fmt_stratum_qual ff obj.obj_stratum;
   fmt ff "obj ";
   fmt_ident_and_params ff id params;
   fmt_header_slots ff obj.obj_state;
@@ -1719,8 +1719,8 @@ and fmt_mod_item (ff:Format.formatter) (id:ident) (item:mod_item) : unit =
   let params = Array.map (fun i -> i.node) params in
     begin
       match item.node.decl_item with
-          MOD_ITEM_type (e, ty) ->
-            fmt_effect_qual ff e;
+          MOD_ITEM_type (s, ty) ->
+            fmt_stratum_qual ff s;
             fmt ff "type ";
             fmt_ident_and_params ff id params;
             fmt ff " = ";
diff --git a/src/boot/fe/fuzz.ml b/src/boot/fe/fuzz.ml
index e8db9f39..734ef06c 100644
--- a/src/boot/fe/fuzz.ml
+++ b/src/boot/fe/fuzz.ml
@@ -104,8 +104,8 @@ let rec generate_mod_item (mis:mod_items) (cx:ctxt) : unit =
     match Random.int 2 with
         0 ->
           let ty = generate_ty cx in
-          let eff = Ast.EFF_pure in
-            decl (MOD_ITEM_type (eff, ty))
+          let st = Ast.STRAT_value in
+            decl (MOD_ITEM_type (st, ty))
       | _ ->
           let mis' = Hashtbl.create 0 in
           let view = { view_imports = Hashtbl.create 0;
diff --git a/src/boot/fe/item.ml b/src/boot/fe/item.ml
index 4c9bd556..fc144439 100644
--- a/src/boot/fe/item.ml
+++ b/src/boot/fe/item.ml
@@ -692,13 +692,12 @@ and parse_stmts_including_none (ps:pstate) : Ast.stmt array =
 and parse_ty_param (iref:int ref) (ps:pstate) : Ast.ty_param identified =
   let apos = lexpos ps in
   let _ = Pexp.parse_opacity ps in
-  let _ = Pexp.parse_stratum ps in
-  let e = Pexp.parse_effect ps in
+  let s = Pexp.parse_stratum ps in
   let ident = Pexp.parse_ident ps in
   let i = !iref in
   let bpos = lexpos ps in
     incr iref;
-    span ps apos bpos (ident, (i, e))
+    span ps apos bpos (ident, (i, s))
 
 and parse_ty_params (ps:pstate)
     : (Ast.ty_param identified) array =
@@ -843,7 +842,7 @@ and parse_optional_meta_pat (ps:pstate) (ident:Ast.ident) : Ast.meta_pat =
 and parse_obj_item
     (ps:pstate)
     (apos:pos)
-    (effect:Ast.effect)
+    (stratum:Ast.stratum)
     : (Ast.ident * Ast.mod_item) =
   expect ps OBJ;
   let (ident, params) = parse_ident_and_params ps "obj" in
@@ -872,7 +871,7 @@ and parse_obj_item
       expect ps RBRACE;
       let bpos = lexpos ps in
       let obj = { Ast.obj_state = state;
-                  Ast.obj_effect = effect;
+                  Ast.obj_stratum = stratum;
                   Ast.obj_constrs = constrs;
                   Ast.obj_fns = fns;
                   Ast.obj_drop = !drop }
@@ -884,7 +883,7 @@ and parse_obj_item
 and parse_tag_item
     (ps:pstate)
     (apos:pos)
-    (effect:Ast.effect)
+    (stratum:Ast.stratum)
     : (Ast.ident * Ast.mod_item) array =
   expect ps TAG;
   let (ident, params) = parse_ident_and_params ps "tag" in
@@ -946,14 +945,14 @@ and parse_tag_item
   let ty_item =
     (ident,
      span ps apos bpos
-       (decl params (Ast.MOD_ITEM_type (effect, ty))))
+       (decl params (Ast.MOD_ITEM_type (stratum, ty))))
   in
     Array.append [| ty_item |] constructors
 
 and parse_type_item
     (ps:pstate)
     (apos:pos)
-    (effect:Ast.effect)
+    (stratum:Ast.stratum)
     : (Ast.ident * Ast.mod_item) =
   expect ps TYPE;
   let (ident, params) = parse_ident_and_params ps "type" in
@@ -961,7 +960,7 @@ and parse_type_item
   let ty = ctxt "mod type item: ty" Pexp.parse_ty ps in
   let _ = expect ps SEMI in
   let bpos = lexpos ps in
-  let item = Ast.MOD_ITEM_type (effect, ty) in
+  let item = Ast.MOD_ITEM_type (stratum, ty) in
     (ident, span ps apos bpos (decl params item))
 
 and parse_mod_item (ps:pstate)
@@ -993,14 +992,25 @@ and parse_mod_item (ps:pstate)
         STATE | GC | IMPURE | UNSAFE | ABS
       | TYPE | OBJ | TAG | FN | ITER ->
           let _ = Pexp.parse_opacity ps in
-          let _ = Pexp.parse_stratum ps in
+          let stratum = Pexp.parse_stratum ps in
           let effect = Pexp.parse_effect ps in
             begin
               match peek ps with
-                  OBJ -> [| parse_obj_item ps apos effect |]
-                | TAG -> parse_tag_item ps apos effect
-                | TYPE -> [| parse_type_item ps apos effect |]
+                  OBJ ->
+                    if effect <> Ast.EFF_pure
+                    then raise (err "effect specified for obj" ps);
+                    [| parse_obj_item ps apos stratum |]
+                | TAG ->
+                    if effect <> Ast.EFF_pure
+                    then raise (err "effect specified for tag" ps);
+                    parse_tag_item ps apos stratum
+                | TYPE ->
+                    if effect <> Ast.EFF_pure
+                    then raise (err "effect specified for type" ps);
+                    [| parse_type_item ps apos stratum |]
                 | _ ->
+                    if stratum <> Ast.STRAT_value
+                    then raise (err "stratum specified for fn or iter" ps);
                     let is_iter = (peek ps) = ITER in
                       bump ps;
                       let (ident, params) = parse_ident_and_params ps "fn" in
@@ -1149,7 +1159,7 @@ and parse_native_mod_item_from_signature (ps:pstate)
           expect ps SEMI;
           let bpos = lexpos ps in
             [| (ident, span ps apos bpos
-                  (decl params (Ast.MOD_ITEM_type (Ast.EFF_unsafe, t)))) |]
+                  (decl params (Ast.MOD_ITEM_type (Ast.STRAT_value, t)))) |]
 
     | _ -> raise (unexpected ps)
 
diff --git a/src/boot/fe/pexp.ml b/src/boot/fe/pexp.ml
index 59cfaf75..1b26431d 100644
--- a/src/boot/fe/pexp.ml
+++ b/src/boot/fe/pexp.ml
@@ -273,14 +273,15 @@ and parse_atomic_ty (ps:pstate) : Ast.ty =
         bump ps;
         Ast.TY_mach m
 
-    | ABS | STATE | GC | IMPURE | UNSAFE | OBJ | FN | ITER ->
-        let _ = parse_opacity ps in
-        let _ = parse_stratum ps in
+    | STATE | GC | IMPURE | UNSAFE | OBJ | FN | ITER ->
+        let stratum = parse_stratum ps in
         let effect = parse_effect ps in
           begin
             match peek ps with
                 OBJ ->
                   bump ps;
+                  if effect <> Ast.EFF_pure
+                  then raise (err "effect specified for obj" ps);
                   let methods = Hashtbl.create 0 in
                   let parse_method ps =
                     let effect = parse_effect ps in
@@ -294,9 +295,11 @@ and parse_atomic_ty (ps:pstate) : Ast.ty =
                   in
                     ignore (bracketed_zero_or_more LBRACE RBRACE
                               None parse_method ps);
-                    Ast.TY_obj (effect, methods)
+                    Ast.TY_obj (stratum, methods)
 
               | FN | ITER ->
+                  if stratum <> Ast.STRAT_value
+                  then raise (err "stratum specified for fn or iter" ps);
                   Ast.TY_fn (fst (parse_ty_fn effect ps))
               | _ -> raise (unexpected ps)
           end
diff --git a/src/boot/me/dwarf.ml b/src/boot/me/dwarf.ml
index 86a0c8a6..2a2ba2c7 100644
--- a/src/boot/me/dwarf.ml
+++ b/src/boot/me/dwarf.ml
@@ -1539,17 +1539,33 @@ let dwarf_visitor
       |]
   in
 
+  let encode_stratum eff =
+    (* Note: weird encoding: mutable+pure = gc. *)
+    let mut_byte, pure_byte =
+      match eff with
+          Ast.STRAT_value -> (0,1)
+        | Ast.STRAT_state -> (1,0)
+        | Ast.STRAT_gc -> (1,1)
+    in
+      SEQ [|
+        (* DW_AT_mutable: DW_FORM_flag *)
+        BYTE mut_byte;
+        (* DW_AT_pure: DW_FORM_flag *)
+        BYTE pure_byte;
+      |]
+  in
+
   (* Type-param DIEs. *)
 
-  let type_param_die (p:(ty_param_idx * Ast.effect)) =
-    let (idx, eff) = p in
+  let type_param_die (p:(ty_param_idx * Ast.stratum)) =
+    let (idx, s) = p in
       SEQ [|
         uleb (get_abbrev_code abbrev_rust_type_param);
         (* DW_AT_rust_type_code: DW_FORM_data1 *)
         BYTE (dw_rust_type_to_int DW_RUST_type_param);
         (* DW_AT_rust_type_param_index: DW_FORM_data4 *)
         WORD (word_ty_mach, IMM (Int64.of_int idx));
-        encode_effect eff;
+        encode_stratum s;
       |]
   in
 
@@ -1801,7 +1817,7 @@ let dwarf_visitor
           emit_die die
       in
 
-      let rust_type_param (p:(ty_param_idx * Ast.effect)) =
+      let rust_type_param (p:(ty_param_idx * Ast.stratum)) =
         let die = DEF (fix, type_param_die p) in
           emit_die die
       in
@@ -1872,11 +1888,11 @@ let dwarf_visitor
           emit_null_die ();
       in
 
-      let obj_type (eff,ob) =
+      let obj_type (str,ob) =
         let die =
           DEF (fix, SEQ [|
                  uleb (get_abbrev_code abbrev_obj_type);
-                 encode_effect eff;
+                 encode_stratum str;
                |])
         in
           emit_die die;
@@ -2239,8 +2255,8 @@ let dwarf_visitor
       curr_cu_line := []
   in
 
-  let type_param_decl_die (p:(Ast.ident * (ty_param_idx * Ast.effect))) =
-    let (ident, (idx, eff)) = p in
+  let type_param_decl_die (p:(Ast.ident * (ty_param_idx * Ast.stratum))) =
+    let (ident, (idx, str)) = p in
       SEQ [|
         uleb (get_abbrev_code abbrev_rust_type_param_decl);
         (* DW_AT_rust_type_code: DW_FORM_data1 *)
@@ -2249,7 +2265,7 @@ let dwarf_visitor
         ZSTRING (Filename.basename ident);
         (* DW_AT_rust_type_param_index: DW_FORM_data4 *)
         WORD (word_ty_mach, IMM (Int64.of_int idx));
-        encode_effect eff;
+        encode_stratum str;
       |]
   in
 
@@ -2344,7 +2360,7 @@ let dwarf_visitor
 
   let emit_typedef_die
       (id:Ast.ident)
-      (e:Ast.effect)
+      (s:Ast.stratum)
       (ty:Ast.ty)
       : unit =
     let abbrev_code = get_abbrev_code abbrev_typedef in
@@ -2353,7 +2369,7 @@ let dwarf_visitor
          uleb abbrev_code;
          (* DW_AT_name: DW_FORM_string *)
          ZSTRING id;
-         encode_effect e;
+         encode_stratum s;
          (* DW_AT_type: DW_FORM_ref_addr *)
          (ref_type_die ty);
        |])
@@ -2418,13 +2434,13 @@ let dwarf_visitor
                 emit_type_param_decl_dies item.node.Ast.decl_params;
             end
 
-        | Ast.MOD_ITEM_type (e, _) ->
+        | Ast.MOD_ITEM_type (s, _) ->
             begin
               log cx "walking typedef '%s' with %d type params"
                 (path_name())
                 (Array.length item.node.Ast.decl_params);
               emit_typedef_die
-                id e (Hashtbl.find cx.ctxt_all_type_items item.id);
+                id s (Hashtbl.find cx.ctxt_all_type_items item.id);
               emit_type_param_decl_dies item.node.Ast.decl_params;
             end
 
@@ -2893,12 +2909,21 @@ let rec extract_mod_items
       | _ -> failwith "bad effect encoding"
   in
 
+  let get_stratum die =
+    match (get_flag die DW_AT_mutable, get_flag die DW_AT_pure) with
+        (* Note: weird encoding: mutable+pure = gc. *)
+      | (false, true) -> Ast.STRAT_value
+      | (true, false) -> Ast.STRAT_state
+      | (true, true) -> Ast.STRAT_gc
+      | _ -> failwith "bad statum encoding"
+  in
+
   let get_name die = get_str die DW_AT_name in
 
   let get_type_param die =
     let idx = get_num die DW_AT_rust_type_param_index in
-    let e = get_effect die in
-      (idx, e)
+    let s = get_stratum die in
+      (idx, s)
   in
 
   let get_native_id die =
@@ -3046,7 +3071,7 @@ let rec extract_mod_items
             end
 
         | DW_TAG_interface_type ->
-            let eff = get_effect die in
+            let str = get_stratum die in
             let fns = Hashtbl.create 0 in
               Array.iter
                 begin
@@ -3056,7 +3081,7 @@ let rec extract_mod_items
                       Hashtbl.add fns (get_name child) (get_ty_fn child)
                 end
                 die.die_children;
-              Ast.TY_obj (eff,fns)
+              Ast.TY_obj (str,fns)
 
         | DW_TAG_subroutine_type ->
             Ast.TY_fn (get_ty_fn die)
@@ -3162,10 +3187,10 @@ let rec extract_mod_items
   let die = Hashtbl.find dies i in
     match die.die_tag with
         DW_TAG_typedef ->
-          let effect = get_effect die in
+          let stratum = get_stratum die in
           let ident = get_name die in
           let ty = get_referenced_ty die in
-          let tyi = Ast.MOD_ITEM_type (effect, ty) in
+          let tyi = Ast.MOD_ITEM_type (stratum, ty) in
           let (params, islots) = get_formals die in
             assert ((Array.length islots) = 0);
             htab_put mis ident (decl params tyi)
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 1b65c0db..f7ad923e 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -729,7 +729,7 @@ type ('ty, 'tys, 'slot, 'slots, 'tag) ty_fold =
       ty_fold_vec : 'ty -> 'ty;
       ty_fold_rec : (Ast.ident * 'ty) array -> 'ty;
       ty_fold_fn : (('slots * Ast.constrs * 'slot) * Ast.ty_fn_aux) -> 'ty;
-      ty_fold_obj : (Ast.effect
+      ty_fold_obj : (Ast.stratum
                      * (Ast.ident, (('slots * Ast.constrs * 'slot) *
                                       Ast.ty_fn_aux)) Hashtbl.t) -> 'ty;
       ty_fold_chan : 'ty -> 'ty;
@@ -737,7 +737,7 @@ type ('ty, 'tys, 'slot, 'slots, 'tag) ty_fold =
       ty_fold_task : unit -> 'ty;
       ty_fold_native : opaque_id -> 'ty;
       ty_fold_tag : 'tag -> 'ty;
-      ty_fold_param : (int * Ast.effect) -> 'ty;
+      ty_fold_param : (int * Ast.stratum) -> 'ty;
       ty_fold_named : Ast.name -> 'ty;
       ty_fold_type : unit -> 'ty;
       ty_fold_box : 'ty -> 'ty;
@@ -909,7 +909,7 @@ let rec fold_ty_full
   | Ast.TY_chan t -> f.ty_fold_chan (fold_ty cx f t)
   | Ast.TY_port t -> f.ty_fold_port (fold_ty cx f t)
 
-  | Ast.TY_obj (eff,t) -> f.ty_fold_obj (eff, (fold_obj t))
+  | Ast.TY_obj (st,t) -> f.ty_fold_obj (st, (fold_obj t))
   | Ast.TY_task -> f.ty_fold_task ()
 
   | Ast.TY_native x -> f.ty_fold_native x
@@ -962,7 +962,7 @@ let ty_fold_rebuild (id:Ast.ty -> Ast.ty)
     ty_fold_task = (fun _ -> id Ast.TY_task);
     ty_fold_native = (fun oid -> id (Ast.TY_native oid));
     ty_fold_tag = (fun ttag -> id (Ast.TY_tag ttag));
-    ty_fold_param = (fun (i, mut) -> id (Ast.TY_param (i, mut)));
+    ty_fold_param = (fun (i, s) -> id (Ast.TY_param (i, s)));
     ty_fold_named = (fun n -> id (Ast.TY_named n));
     ty_fold_type = (fun _ -> id (Ast.TY_type));
     ty_fold_box = (fun t -> id (Ast.TY_box t));
@@ -1047,8 +1047,8 @@ let rec rebuild_ty_under_params
     in
     let rec rebuild_ty t =
       let base = ty_fold_rebuild (fun t -> t) in
-      let ty_fold_param (i, mut) =
-        let param = Ast.TY_param (i, mut) in
+      let ty_fold_param (i, s) =
+        let param = Ast.TY_param (i, s) in
           match htab_search pmap param with
               None -> param
             | Some arg -> arg
@@ -1629,7 +1629,7 @@ let ty_fn_of_fn (fn:Ast.fn) : Ast.ty_fn =
 ;;
 
 let ty_obj_of_obj (obj:Ast.obj) : Ast.ty_obj =
-  (obj.Ast.obj_effect,
+  (obj.Ast.obj_stratum,
    htab_map obj.Ast.obj_fns (fun i f -> (i, ty_fn_of_fn f.node)))
 ;;