First pass on splitting stratum and opacity off of effects. WIP.

4 files changed, 47 insertions, 34 deletions

diff --git a/src/boot/me/dwarf.ml b/src/boot/me/dwarf.ml
index 08f8c347..86a0c8a6 100644
--- a/src/boot/me/dwarf.ml
+++ b/src/boot/me/dwarf.ml
@@ -1527,10 +1527,9 @@ let dwarf_visitor
     (* Note: weird encoding: mutable+pure = unsafe. *)
     let mut_byte, pure_byte =
       match eff with
-          Ast.UNSAFE -> (1,1)
-        | Ast.STATE -> (1,0)
-        | Ast.IO -> (0,0)
-        | Ast.PURE -> (0,1)
+          Ast.EFF_unsafe -> (1,1)
+        | Ast.EFF_impure -> (0,0)
+        | Ast.EFF_pure -> (0,1)
     in
       SEQ [|
         (* DW_AT_mutable: DW_FORM_flag *)
@@ -2888,10 +2887,10 @@ let rec extract_mod_items
   let get_effect die =
     match (get_flag die DW_AT_mutable, get_flag die DW_AT_pure) with
         (* Note: weird encoding: mutable+pure = unsafe. *)
-        (true, true) -> Ast.UNSAFE
-      | (true, false) -> Ast.STATE
-      | (false, false) -> Ast.IO
-      | (false, true) -> Ast.PURE
+        (true, true) -> Ast.EFF_unsafe
+      | (false, false) -> Ast.EFF_impure
+      | (false, true) -> Ast.EFF_pure
+      | _ -> failwith "bad effect encoding"
   in
 
   let get_name die = get_str die DW_AT_name in
diff --git a/src/boot/me/effect.ml b/src/boot/me/effect.ml
index 8a8292d9..3bb761ef 100644
--- a/src/boot/me/effect.ml
+++ b/src/boot/me/effect.ml
@@ -92,7 +92,7 @@ let function_effect_propagation_visitor
    * This visitor calculates the effect of each function according to
    * its statements:
    * 
-   *    - Communication lowers to 'io'
+   *    - Communication statements lower to 'impure'
    *    - Native calls lower to 'unsafe'
    *    - Calling a function with effect e lowers to e.
    *)
@@ -138,7 +138,7 @@ let function_effect_propagation_visitor
     let fn_id = Stack.top curr_fn in
     let e =
       match htab_search item_effect fn_id with
-          None -> Ast.PURE
+          None -> Ast.EFF_pure
         | Some e -> e
     in
     let ne = lower_effect_of ne e in
@@ -163,7 +163,7 @@ let function_effect_propagation_visitor
     begin
       match s.node with
           Ast.STMT_send _
-        | Ast.STMT_recv _ -> lower_to s Ast.IO
+        | Ast.STMT_recv _ -> lower_to s Ast.EFF_impure
 
         | Ast.STMT_call (_, fn, _) ->
             let lower_to_callee_ty t =
@@ -183,7 +183,7 @@ let function_effect_propagation_visitor
                     match htab_search cx.ctxt_required_items item.id with
                         None -> ()
                       | Some (REQUIRED_LIB_rust _, _) -> ()
-                      | Some _ -> lower_to s Ast.UNSAFE
+                      | Some _ -> lower_to s Ast.EFF_unsafe
                 end
         | _ -> ()
     end;
@@ -232,7 +232,7 @@ let effect_checking_visitor
         | Some e ->
             let curr =
               if Stack.is_empty auth_stack
-              then Ast.PURE
+              then Ast.EFF_pure
               else Stack.top auth_stack
             in
             let next = lower_effect_of e curr in
@@ -253,7 +253,7 @@ let effect_checking_visitor
           Ast.MOD_ITEM_fn f ->
             let e =
               match htab_search item_effect i.id with
-                None -> Ast.PURE
+                None -> Ast.EFF_pure
               | Some e -> e
             in
             let fe = f.Ast.fn_aux.Ast.fn_effect in
@@ -291,7 +291,7 @@ let effect_checking_visitor
           let curr = Stack.pop auth_stack in
           let next =
             if Stack.is_empty auth_stack
-            then Ast.PURE
+            then Ast.EFF_pure
             else Stack.top auth_stack
           in
           iflog cx
diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml
index 1eb88ab1..1b65c0db 100644
--- a/src/boot/me/semant.ml
+++ b/src/boot/me/semant.ml
@@ -191,7 +191,7 @@ type ctxt =
 
       ctxt_rty_cache: (Ast.ty,Il.referent_ty) Hashtbl.t;
 
-      ctxt_type_effect_cache: (Ast.ty,Ast.effect) Hashtbl.t;
+      ctxt_type_stratum_cache: (Ast.ty,Ast.stratum) Hashtbl.t;
       ctxt_type_points_to_heap_cache: (Ast.ty,bool) Hashtbl.t;
       ctxt_type_is_structured_cache: (Ast.ty,bool) Hashtbl.t;
       ctxt_type_contains_chan_cache: (Ast.ty,bool) Hashtbl.t;
@@ -296,7 +296,7 @@ let new_ctxt sess abi crate =
     ctxt_curr_path = Stack.create ();
 
     ctxt_rty_cache = Hashtbl.create 0;
-    ctxt_type_effect_cache = Hashtbl.create 0;
+    ctxt_type_stratum_cache = Hashtbl.create 0;
     ctxt_type_points_to_heap_cache = Hashtbl.create 0;
     ctxt_type_is_structured_cache = Hashtbl.create 0;
     ctxt_type_contains_chan_cache = Hashtbl.create 0;
@@ -1227,16 +1227,15 @@ let type_points_to_heap (cx:ctxt) (t:Ast.ty) : bool =
       (fun _ -> fold_ty cx fold t)
 ;;
 
-(* Effect analysis. *)
+
+(* Type qualifier analysis. *)
+
 let effect_le x y =
   match (x,y) with
-      (Ast.UNSAFE, _) -> true
-    | (Ast.STATE, Ast.PURE) -> true
-    | (Ast.STATE, Ast.IO) -> true
-    | (Ast.STATE, Ast.STATE) -> true
-    | (Ast.IO, Ast.PURE) -> true
-    | (Ast.IO, Ast.IO) -> true
-    | (Ast.PURE, Ast.PURE) -> true
+      (Ast.EFF_unsafe, _) -> true
+    | (Ast.EFF_impure, Ast.EFF_pure) -> true
+    | (Ast.EFF_impure, Ast.EFF_impure) -> true
+    | (Ast.EFF_pure, Ast.EFF_pure) -> true
     | _ -> false
 ;;
 
@@ -1244,16 +1243,30 @@ let lower_effect_of x y =
   if effect_le x y then x else y
 ;;
 
-let type_effect (cx:ctxt) (t:Ast.ty) : Ast.effect =
-  let fold_mutable _ = Ast.STATE in
-  let fold = associative_binary_op_ty_fold Ast.PURE lower_effect_of in
+let stratum_le x y =
+  match (x,y) with
+      (Ast.STRAT_gc, _) -> true
+    | (Ast.STRAT_state, Ast.STRAT_value) -> true
+    | (Ast.STRAT_state, Ast.STRAT_state) -> true
+    | (Ast.STRAT_value, Ast.STRAT_value) -> true
+    | _ -> false
+;;
+
+let lower_stratum_of x y =
+  if stratum_le x y then x else y
+;;
+
+let type_stratum (cx:ctxt) (t:Ast.ty) : Ast.stratum =
+  let fold_mutable _ = Ast.STRAT_state in
+  let fold = associative_binary_op_ty_fold Ast.STRAT_value lower_stratum_of in
   let fold = { fold with ty_fold_mutable = fold_mutable } in
-    htab_search_or_add cx.ctxt_type_effect_cache t
+    htab_search_or_add cx.ctxt_type_stratum_cache t
       (fun _ -> fold_ty cx fold t)
 ;;
 
+
 let type_has_state (cx:ctxt) (t:Ast.ty) : bool =
-  effect_le (type_effect cx t) Ast.STATE
+  stratum_le (type_stratum cx t) Ast.STRAT_state
 ;;
 
 
@@ -1627,7 +1640,7 @@ let ty_of_mod_item (item:Ast.mod_item) : Ast.ty =
     | Ast.MOD_ITEM_mod _ -> bug () "Semant.ty_of_mod_item on mod"
     | Ast.MOD_ITEM_const (ty, _) -> ty
     | Ast.MOD_ITEM_obj ob ->
-        let taux = { Ast.fn_effect = Ast.PURE;
+        let taux = { Ast.fn_effect = Ast.EFF_pure;
                      Ast.fn_is_iter = false }
         in
         let tobj = Ast.TY_obj (ty_obj_of_obj ob) in
@@ -1650,7 +1663,7 @@ let ty_of_mod_item (item:Ast.mod_item) : Ast.ty =
           if Array.length hdr = 0
           then Ast.TY_tag ttag
           else
-            let taux = { Ast.fn_effect = Ast.PURE;
+            let taux = { Ast.fn_effect = Ast.EFF_pure;
                          Ast.fn_is_iter = false }
             in
             let inputs = Array.map (fun (s, _) -> s.node) hdr in
@@ -2561,7 +2574,7 @@ let mk_ty_fn_or_iter
     (is_iter:bool)
     : Ast.ty =
   (* In some cases we don't care what aux or constrs are. *)
-  let taux = { Ast.fn_effect = Ast.PURE;
+  let taux = { Ast.fn_effect = Ast.EFF_pure;
                Ast.fn_is_iter = is_iter; }
   in
   let tsig = { Ast.sig_input_slots = arg_slots;
diff --git a/src/boot/me/typestate.ml b/src/boot/me/typestate.ml
index 00629886..0579775f 100644
--- a/src/boot/me/typestate.ml
+++ b/src/boot/me/typestate.ml
@@ -126,7 +126,7 @@ let determine_constr_key
               match Hashtbl.find cx.ctxt_all_item_types cid with
                   Ast.TY_fn (_, taux) ->
                     begin
-                      if taux.Ast.fn_effect = Ast.PURE
+                      if taux.Ast.fn_effect = Ast.EFF_pure
                       then cid
                       else err (Some cid) "impure function used in constraint"
                     end
@@ -989,6 +989,7 @@ let graph_special_block_structure_building_visitor
                         Hashtbl.replace graph cond_id [then_id; else_id];
                         Hashtbl.replace graph then_end_id succ;
                         Hashtbl.replace graph else_end_id succ;
+
                         (* Kill residual messed-up block wiring.*)
                         remove_flow_edges graph then_end_id [then_id];
                         remove_flow_edges graph else_id [then_id];