From a98b2ebb4ad090d3d7eaa9ab3b1d98be0867e990 Mon Sep 17 00:00:00 2001 From: Graydon Hoare Date: Fri, 3 Dec 2010 12:15:32 -0800 Subject: Change 'stratum' to the friendlier term 'layer'. --- src/boot/me/dwarf.ml | 40 +++++++++--------- src/boot/me/layer.ml | 108 +++++++++++++++++++++++++++++++++++++++++++++++++ src/boot/me/semant.ml | 34 ++++++++-------- src/boot/me/stratum.ml | 108 ------------------------------------------------- 4 files changed, 145 insertions(+), 145 deletions(-) create mode 100644 src/boot/me/layer.ml delete mode 100644 src/boot/me/stratum.ml (limited to 'src/boot/me') diff --git a/src/boot/me/dwarf.ml b/src/boot/me/dwarf.ml index 2a2ba2c7..5b7c0ca1 100644 --- a/src/boot/me/dwarf.ml +++ b/src/boot/me/dwarf.ml @@ -1539,13 +1539,13 @@ let dwarf_visitor |] in - let encode_stratum eff = + let encode_layer 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) + Ast.LAYER_value -> (0,1) + | Ast.LAYER_state -> (1,0) + | Ast.LAYER_gc -> (1,1) in SEQ [| (* DW_AT_mutable: DW_FORM_flag *) @@ -1557,7 +1557,7 @@ let dwarf_visitor (* Type-param DIEs. *) - let type_param_die (p:(ty_param_idx * Ast.stratum)) = + let type_param_die (p:(ty_param_idx * Ast.layer)) = let (idx, s) = p in SEQ [| uleb (get_abbrev_code abbrev_rust_type_param); @@ -1565,7 +1565,7 @@ let dwarf_visitor 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_stratum s; + encode_layer s; |] in @@ -1817,7 +1817,7 @@ let dwarf_visitor emit_die die in - let rust_type_param (p:(ty_param_idx * Ast.stratum)) = + let rust_type_param (p:(ty_param_idx * Ast.layer)) = let die = DEF (fix, type_param_die p) in emit_die die in @@ -1892,7 +1892,7 @@ let dwarf_visitor let die = DEF (fix, SEQ [| uleb (get_abbrev_code abbrev_obj_type); - encode_stratum str; + encode_layer str; |]) in emit_die die; @@ -2255,7 +2255,7 @@ let dwarf_visitor curr_cu_line := [] in - let type_param_decl_die (p:(Ast.ident * (ty_param_idx * Ast.stratum))) = + let type_param_decl_die (p:(Ast.ident * (ty_param_idx * Ast.layer))) = let (ident, (idx, str)) = p in SEQ [| uleb (get_abbrev_code abbrev_rust_type_param_decl); @@ -2265,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_stratum str; + encode_layer str; |] in @@ -2360,7 +2360,7 @@ let dwarf_visitor let emit_typedef_die (id:Ast.ident) - (s:Ast.stratum) + (s:Ast.layer) (ty:Ast.ty) : unit = let abbrev_code = get_abbrev_code abbrev_typedef in @@ -2369,7 +2369,7 @@ let dwarf_visitor uleb abbrev_code; (* DW_AT_name: DW_FORM_string *) ZSTRING id; - encode_stratum s; + encode_layer s; (* DW_AT_type: DW_FORM_ref_addr *) (ref_type_die ty); |]) @@ -2909,12 +2909,12 @@ let rec extract_mod_items | _ -> failwith "bad effect encoding" in - let get_stratum die = + let get_layer 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 + | (false, true) -> Ast.LAYER_value + | (true, false) -> Ast.LAYER_state + | (true, true) -> Ast.LAYER_gc | _ -> failwith "bad statum encoding" in @@ -2922,7 +2922,7 @@ let rec extract_mod_items let get_type_param die = let idx = get_num die DW_AT_rust_type_param_index in - let s = get_stratum die in + let s = get_layer die in (idx, s) in @@ -3071,7 +3071,7 @@ let rec extract_mod_items end | DW_TAG_interface_type -> - let str = get_stratum die in + let str = get_layer die in let fns = Hashtbl.create 0 in Array.iter begin @@ -3187,10 +3187,10 @@ let rec extract_mod_items let die = Hashtbl.find dies i in match die.die_tag with DW_TAG_typedef -> - let stratum = get_stratum die in + let layer = get_layer die in let ident = get_name die in let ty = get_referenced_ty die in - let tyi = Ast.MOD_ITEM_type (stratum, ty) in + let tyi = Ast.MOD_ITEM_type (layer, 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/layer.ml b/src/boot/me/layer.ml new file mode 100644 index 00000000..a5a33b0b --- /dev/null +++ b/src/boot/me/layer.ml @@ -0,0 +1,108 @@ +open Semant;; +open Common;; + +let log cx = Session.log "layer" + (should_log cx cx.ctxt_sess.Session.sess_log_layer) + cx.ctxt_sess.Session.sess_log_out +;; + +let iflog cx thunk = + if (should_log cx cx.ctxt_sess.Session.sess_log_layer) + then thunk () + else () +;; + + +let state_layer_checking_visitor + (cx:ctxt) + (inner:Walk.visitor) + : Walk.visitor = + (* + * This visitor enforces the following rules: + * + * - A channel type carrying a state type is illegal. + * + * - Writing to an immutable slot is illegal. + * + * - Forming a mutable alias to an immutable slot is illegal. + * + *) + let visit_ty_pre t = + match t with + Ast.TY_chan t' when type_has_state cx t' -> + err None "channel of state type: %a " Ast.sprintf_ty t' + | _ -> () + in + + let check_write s dst = + let is_init = Hashtbl.mem cx.ctxt_stmt_is_init s.id in + let dst_ty = lval_ty cx dst in + let is_mutable = + match dst_ty with + Ast.TY_mutable _ -> true + | _ -> false + in + iflog cx + (fun _ -> log cx "checking %swrite to %slval #%d = %a of type %a" + (if is_init then "initializing " else "") + (if is_mutable then "mutable " else "") + (int_of_node (lval_base_id dst)) + Ast.sprintf_lval dst + Ast.sprintf_ty dst_ty); + if (is_mutable or is_init) + then () + else err (Some s.id) + "writing to immutable type %a in statement %a" + Ast.sprintf_ty dst_ty Ast.sprintf_stmt s + in + (* FIXME (issue #75): enforce the no-write-alias-to-immutable-slot + * rule. + *) + let visit_stmt_pre s = + begin + match s.node with + Ast.STMT_copy (lv_dst, _) + | Ast.STMT_call (lv_dst, _, _) + | Ast.STMT_spawn (lv_dst, _, _, _, _) + | Ast.STMT_recv (lv_dst, _) + | Ast.STMT_bind (lv_dst, _, _) + | Ast.STMT_new_rec (lv_dst, _, _) + | Ast.STMT_new_tup (lv_dst, _) + | Ast.STMT_new_vec (lv_dst, _, _) + | Ast.STMT_new_str (lv_dst, _) + | Ast.STMT_new_port lv_dst + | Ast.STMT_new_chan (lv_dst, _) + | Ast.STMT_new_box (lv_dst, _, _) -> + check_write s lv_dst + | _ -> () + end; + inner.Walk.visit_stmt_pre s + in + + { inner with + Walk.visit_ty_pre = visit_ty_pre; + Walk.visit_stmt_pre = visit_stmt_pre } +;; + +let process_crate + (cx:ctxt) + (crate:Ast.crate) + : unit = + let passes = + [| + (state_layer_checking_visitor cx + Walk.empty_visitor); + |] + in + run_passes cx "layer" passes + cx.ctxt_sess.Session.sess_log_layer log crate +;; + +(* + * Local Variables: + * fill-column: 78; + * indent-tabs-mode: nil + * buffer-file-coding-system: utf-8-unix + * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'"; + * End: + *) diff --git a/src/boot/me/semant.ml b/src/boot/me/semant.ml index c4930c12..cea0b479 100644 --- a/src/boot/me/semant.ml +++ b/src/boot/me/semant.ml @@ -192,7 +192,7 @@ type ctxt = ctxt_rty_cache: (Ast.ty,Il.referent_ty) Hashtbl.t; - ctxt_type_stratum_cache: (Ast.ty,Ast.stratum) Hashtbl.t; + ctxt_type_layer_cache: (Ast.ty,Ast.layer) 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; @@ -298,7 +298,7 @@ let new_ctxt sess abi crate = ctxt_curr_path = Stack.create (); ctxt_rty_cache = Hashtbl.create 0; - ctxt_type_stratum_cache = Hashtbl.create 0; + ctxt_type_layer_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; @@ -731,7 +731,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.stratum + ty_fold_obj : (Ast.layer * (Ast.ident, (('slots * Ast.constrs * 'slot) * Ast.ty_fn_aux)) Hashtbl.t) -> 'ty; ty_fold_chan : 'ty -> 'ty; @@ -739,7 +739,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.stratum) -> 'ty; + ty_fold_param : (int * Ast.layer) -> 'ty; ty_fold_named : Ast.name -> 'ty; ty_fold_type : unit -> 'ty; ty_fold_box : 'ty -> 'ty; @@ -1253,30 +1253,30 @@ let lower_effect_of x y = if effect_le x y then x else y ;; -let stratum_le x y = +let layer_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 + (Ast.LAYER_gc, _) -> true + | (Ast.LAYER_state, Ast.LAYER_value) -> true + | (Ast.LAYER_state, Ast.LAYER_state) -> true + | (Ast.LAYER_value, Ast.LAYER_value) -> true | _ -> false ;; -let lower_stratum_of x y = - if stratum_le x y then x else y +let lower_layer_of x y = + if layer_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 type_layer (cx:ctxt) (t:Ast.ty) : Ast.layer = + let fold_mutable _ = Ast.LAYER_state in + let fold = associative_binary_op_ty_fold Ast.LAYER_value lower_layer_of in let fold = { fold with ty_fold_mutable = fold_mutable } in - htab_search_or_add cx.ctxt_type_stratum_cache t + htab_search_or_add cx.ctxt_type_layer_cache t (fun _ -> fold_ty cx fold t) ;; let type_has_state (cx:ctxt) (t:Ast.ty) : bool = - stratum_le (type_stratum cx t) Ast.STRAT_state + layer_le (type_layer cx t) Ast.LAYER_state ;; @@ -1640,7 +1640,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_stratum, + (obj.Ast.obj_layer, htab_map obj.Ast.obj_fns (fun i f -> (i, ty_fn_of_fn f.node))) ;; diff --git a/src/boot/me/stratum.ml b/src/boot/me/stratum.ml deleted file mode 100644 index 21598d55..00000000 --- a/src/boot/me/stratum.ml +++ /dev/null @@ -1,108 +0,0 @@ -open Semant;; -open Common;; - -let log cx = Session.log "stratum" - (should_log cx cx.ctxt_sess.Session.sess_log_stratum) - cx.ctxt_sess.Session.sess_log_out -;; - -let iflog cx thunk = - if (should_log cx cx.ctxt_sess.Session.sess_log_stratum) - then thunk () - else () -;; - - -let state_stratum_checking_visitor - (cx:ctxt) - (inner:Walk.visitor) - : Walk.visitor = - (* - * This visitor enforces the following rules: - * - * - A channel type carrying a state type is illegal. - * - * - Writing to an immutable slot is illegal. - * - * - Forming a mutable alias to an immutable slot is illegal. - * - *) - let visit_ty_pre t = - match t with - Ast.TY_chan t' when type_has_state cx t' -> - err None "channel of state type: %a " Ast.sprintf_ty t' - | _ -> () - in - - let check_write s dst = - let is_init = Hashtbl.mem cx.ctxt_stmt_is_init s.id in - let dst_ty = lval_ty cx dst in - let is_mutable = - match dst_ty with - Ast.TY_mutable _ -> true - | _ -> false - in - iflog cx - (fun _ -> log cx "checking %swrite to %slval #%d = %a of type %a" - (if is_init then "initializing " else "") - (if is_mutable then "mutable " else "") - (int_of_node (lval_base_id dst)) - Ast.sprintf_lval dst - Ast.sprintf_ty dst_ty); - if (is_mutable or is_init) - then () - else err (Some s.id) - "writing to immutable type %a in statement %a" - Ast.sprintf_ty dst_ty Ast.sprintf_stmt s - in - (* FIXME (issue #75): enforce the no-write-alias-to-immutable-slot - * rule. - *) - let visit_stmt_pre s = - begin - match s.node with - Ast.STMT_copy (lv_dst, _) - | Ast.STMT_call (lv_dst, _, _) - | Ast.STMT_spawn (lv_dst, _, _, _, _) - | Ast.STMT_recv (lv_dst, _) - | Ast.STMT_bind (lv_dst, _, _) - | Ast.STMT_new_rec (lv_dst, _, _) - | Ast.STMT_new_tup (lv_dst, _) - | Ast.STMT_new_vec (lv_dst, _, _) - | Ast.STMT_new_str (lv_dst, _) - | Ast.STMT_new_port lv_dst - | Ast.STMT_new_chan (lv_dst, _) - | Ast.STMT_new_box (lv_dst, _, _) -> - check_write s lv_dst - | _ -> () - end; - inner.Walk.visit_stmt_pre s - in - - { inner with - Walk.visit_ty_pre = visit_ty_pre; - Walk.visit_stmt_pre = visit_stmt_pre } -;; - -let process_crate - (cx:ctxt) - (crate:Ast.crate) - : unit = - let passes = - [| - (state_stratum_checking_visitor cx - Walk.empty_visitor); - |] - in - run_passes cx "stratum" passes - cx.ctxt_sess.Session.sess_log_stratum log crate -;; - -(* - * Local Variables: - * fill-column: 78; - * indent-tabs-mode: nil - * buffer-file-coding-system: utf-8-unix - * compile-command: "make -k -C ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'"; - * End: - *) -- cgit v1.2.3