Initial stab at lowering mutable and exterior into the type system.
This commit is contained in:
parent
ffdcd67c25
commit
1f9fd2710e
|
@ -16,8 +16,8 @@ let alt_pipeline sess sem_cx crate =
|
||||||
[|
|
[|
|
||||||
Resolve.process_crate;
|
Resolve.process_crate;
|
||||||
Type.process_crate;
|
Type.process_crate;
|
||||||
Effect.process_crate;
|
|
||||||
Typestate.process_crate;
|
Typestate.process_crate;
|
||||||
|
Effect.process_crate;
|
||||||
Loop.process_crate;
|
Loop.process_crate;
|
||||||
Alias.process_crate;
|
Alias.process_crate;
|
||||||
Dead.process_crate;
|
Dead.process_crate;
|
||||||
|
|
|
@ -316,8 +316,8 @@ let main_pipeline _ =
|
||||||
exit_if_failed ())
|
exit_if_failed ())
|
||||||
[| Resolve.process_crate;
|
[| Resolve.process_crate;
|
||||||
Type.process_crate;
|
Type.process_crate;
|
||||||
Effect.process_crate;
|
|
||||||
Typestate.process_crate;
|
Typestate.process_crate;
|
||||||
|
Effect.process_crate;
|
||||||
Loop.process_crate;
|
Loop.process_crate;
|
||||||
Alias.process_crate;
|
Alias.process_crate;
|
||||||
Dead.process_crate;
|
Dead.process_crate;
|
||||||
|
|
|
@ -9,11 +9,6 @@
|
||||||
open Common;;
|
open Common;;
|
||||||
open Fmt;;
|
open Fmt;;
|
||||||
|
|
||||||
(*
|
|
||||||
* Slot names are given by a dot-separated path within the current
|
|
||||||
* module namespace.
|
|
||||||
*)
|
|
||||||
|
|
||||||
type ident = string
|
type ident = string
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
@ -70,11 +65,11 @@ and ty =
|
||||||
| TY_str
|
| TY_str
|
||||||
|
|
||||||
| TY_tup of ty_tup
|
| TY_tup of ty_tup
|
||||||
| TY_vec of slot
|
| TY_vec of ty
|
||||||
| TY_rec of ty_rec
|
| TY_rec of ty_rec
|
||||||
|
|
||||||
(*
|
(*
|
||||||
* Note that ty_idx is only valid inside a slot of a ty_iso group, not
|
* Note that ty_idx is only valid inside a ty of a ty_iso group, not
|
||||||
* in a general type term.
|
* in a general type term.
|
||||||
*)
|
*)
|
||||||
| TY_tag of ty_tag
|
| TY_tag of ty_tag
|
||||||
|
@ -93,18 +88,25 @@ and ty =
|
||||||
| TY_named of name
|
| TY_named of name
|
||||||
| TY_type
|
| TY_type
|
||||||
|
|
||||||
|
| TY_exterior of ty
|
||||||
|
| TY_mutable of ty
|
||||||
|
|
||||||
| TY_constrained of (ty * constrs)
|
| TY_constrained of (ty * constrs)
|
||||||
|
|
||||||
|
(*
|
||||||
|
* FIXME: this should be cleaned up to be a different
|
||||||
|
* type definition. Only args can be by-ref, only locals
|
||||||
|
* can be auto. The structure here is historical.
|
||||||
|
*)
|
||||||
|
|
||||||
and mode =
|
and mode =
|
||||||
MODE_exterior
|
|
||||||
| MODE_interior
|
| MODE_interior
|
||||||
| MODE_alias
|
| MODE_alias
|
||||||
|
|
||||||
and slot = { slot_mode: mode;
|
and slot = { slot_mode: mode;
|
||||||
slot_mutable: bool;
|
|
||||||
slot_ty: ty option; }
|
slot_ty: ty option; }
|
||||||
|
|
||||||
and ty_tup = slot array
|
and ty_tup = ty array
|
||||||
|
|
||||||
(* In closed type terms a constraint may refer to components of the term by
|
(* In closed type terms a constraint may refer to components of the term by
|
||||||
* anchoring off the "formal symbol" '*', which represents "the term this
|
* anchoring off the "formal symbol" '*', which represents "the term this
|
||||||
|
@ -147,7 +149,7 @@ and constr =
|
||||||
|
|
||||||
and constrs = constr array
|
and constrs = constr array
|
||||||
|
|
||||||
and ty_rec = (ident * slot) array
|
and ty_rec = (ident * ty) array
|
||||||
|
|
||||||
(* ty_tag is a sum type.
|
(* ty_tag is a sum type.
|
||||||
*
|
*
|
||||||
|
@ -185,9 +187,9 @@ and ty_obj = (effect * ((ident,ty_fn) Hashtbl.t))
|
||||||
|
|
||||||
and check_calls = (lval * (atom array)) array
|
and check_calls = (lval * (atom array)) array
|
||||||
|
|
||||||
and rec_input = (ident * mode * bool * atom)
|
and rec_input = (ident * atom)
|
||||||
|
|
||||||
and tup_input = (mode * bool * atom)
|
and tup_input = atom
|
||||||
|
|
||||||
and stmt' =
|
and stmt' =
|
||||||
|
|
||||||
|
@ -195,10 +197,11 @@ and stmt' =
|
||||||
STMT_spawn of (lval * domain * lval * (atom array))
|
STMT_spawn of (lval * domain * lval * (atom array))
|
||||||
| STMT_init_rec of (lval * (rec_input array) * lval option)
|
| STMT_init_rec of (lval * (rec_input array) * lval option)
|
||||||
| STMT_init_tup of (lval * (tup_input array))
|
| STMT_init_tup of (lval * (tup_input array))
|
||||||
| STMT_init_vec of (lval * slot * (atom array))
|
| STMT_init_vec of (lval * atom array)
|
||||||
| STMT_init_str of (lval * string)
|
| STMT_init_str of (lval * string)
|
||||||
| STMT_init_port of lval
|
| STMT_init_port of lval
|
||||||
| STMT_init_chan of (lval * (lval option))
|
| STMT_init_chan of (lval * (lval option))
|
||||||
|
| STMT_init_exterior of (lval * atom)
|
||||||
| STMT_copy of (lval * expr)
|
| STMT_copy of (lval * expr)
|
||||||
| STMT_copy_binop of (lval * binop * atom)
|
| STMT_copy_binop of (lval * binop * atom)
|
||||||
| STMT_call of (lval * lval * (atom array))
|
| STMT_call of (lval * lval * (atom array))
|
||||||
|
@ -516,13 +519,8 @@ and fmt_name (ff:Format.formatter) (n:name) : unit =
|
||||||
fmt ff ".";
|
fmt ff ".";
|
||||||
fmt_name_component ff nc
|
fmt_name_component ff nc
|
||||||
|
|
||||||
and fmt_mutable (ff:Format.formatter) (m:bool) : unit =
|
|
||||||
if m
|
|
||||||
then fmt ff "mutable ";
|
|
||||||
|
|
||||||
and fmt_mode (ff:Format.formatter) (m:mode) : unit =
|
and fmt_mode (ff:Format.formatter) (m:mode) : unit =
|
||||||
match m with
|
match m with
|
||||||
MODE_exterior -> fmt ff "@@"
|
|
||||||
| MODE_alias -> fmt ff "&"
|
| MODE_alias -> fmt ff "&"
|
||||||
| MODE_interior -> ()
|
| MODE_interior -> ()
|
||||||
|
|
||||||
|
@ -530,10 +528,27 @@ and fmt_slot (ff:Format.formatter) (s:slot) : unit =
|
||||||
match s.slot_ty with
|
match s.slot_ty with
|
||||||
None -> fmt ff "auto"
|
None -> fmt ff "auto"
|
||||||
| Some t ->
|
| Some t ->
|
||||||
fmt_mutable ff s.slot_mutable;
|
|
||||||
fmt_mode ff s.slot_mode;
|
fmt_mode ff s.slot_mode;
|
||||||
fmt_ty ff t
|
fmt_ty ff t
|
||||||
|
|
||||||
|
and fmt_tys
|
||||||
|
(ff:Format.formatter)
|
||||||
|
(tys:ty array)
|
||||||
|
: unit =
|
||||||
|
fmt_bracketed_arr_sep "(" ")" "," fmt_ty ff tys
|
||||||
|
|
||||||
|
and fmt_ident_tys
|
||||||
|
(ff:Format.formatter)
|
||||||
|
(entries:(ident * ty) array)
|
||||||
|
: unit =
|
||||||
|
fmt_bracketed_arr_sep "(" ")" ","
|
||||||
|
(fun ff (ident, ty) ->
|
||||||
|
fmt_ty ff ty;
|
||||||
|
fmt ff " ";
|
||||||
|
fmt_ident ff ident)
|
||||||
|
ff
|
||||||
|
entries
|
||||||
|
|
||||||
and fmt_slots
|
and fmt_slots
|
||||||
(ff:Format.formatter)
|
(ff:Format.formatter)
|
||||||
(slots:slot array)
|
(slots:slot array)
|
||||||
|
@ -594,7 +609,7 @@ and fmt_tag (ff:Format.formatter) (ttag:ty_tag) : unit =
|
||||||
then first := false
|
then first := false
|
||||||
else fmt ff ",@ ");
|
else fmt ff ",@ ");
|
||||||
fmt_name ff name;
|
fmt_name ff name;
|
||||||
fmt_slots ff ttup None
|
fmt_tys ff ttup
|
||||||
end
|
end
|
||||||
ttag;
|
ttag;
|
||||||
fmt ff "@])@]"
|
fmt ff "@])@]"
|
||||||
|
@ -623,19 +638,15 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit =
|
||||||
| TY_char -> fmt ff "char"
|
| TY_char -> fmt ff "char"
|
||||||
| TY_str -> fmt ff "str"
|
| TY_str -> fmt ff "str"
|
||||||
|
|
||||||
| TY_tup slots -> (fmt ff "tup"; fmt_slots ff slots None)
|
| TY_tup tys -> (fmt ff "tup"; fmt_tys ff tys)
|
||||||
| TY_vec s -> (fmt ff "vec["; fmt_slot ff s; fmt ff "]")
|
| TY_vec t -> (fmt ff "vec["; fmt_ty ff t; fmt ff "]")
|
||||||
| TY_chan t -> (fmt ff "chan["; fmt_ty ff t; fmt ff "]")
|
| TY_chan t -> (fmt ff "chan["; fmt_ty ff t; fmt ff "]")
|
||||||
| TY_port t -> (fmt ff "port["; fmt_ty ff t; fmt ff "]")
|
| TY_port t -> (fmt ff "port["; fmt_ty ff t; fmt ff "]")
|
||||||
|
|
||||||
| TY_rec slots ->
|
| TY_rec entries ->
|
||||||
let (idents, slots) =
|
fmt ff "@[rec";
|
||||||
let (idents, slots) = List.split (Array.to_list slots) in
|
fmt_ident_tys ff entries;
|
||||||
(Array.of_list idents, Array.of_list slots)
|
fmt ff "@]"
|
||||||
in
|
|
||||||
fmt ff "@[rec";
|
|
||||||
fmt_slots ff slots (Some idents);
|
|
||||||
fmt ff "@]"
|
|
||||||
|
|
||||||
| TY_param (i, e) -> (fmt_effect ff e;
|
| TY_param (i, e) -> (fmt_effect ff e;
|
||||||
if e <> PURE then fmt ff " ";
|
if e <> PURE then fmt ff " ";
|
||||||
|
@ -644,6 +655,14 @@ and fmt_ty (ff:Format.formatter) (t:ty) : unit =
|
||||||
| TY_named n -> fmt_name ff n
|
| TY_named n -> fmt_name ff n
|
||||||
| TY_type -> fmt ff "type"
|
| TY_type -> fmt ff "type"
|
||||||
|
|
||||||
|
| TY_exterior t ->
|
||||||
|
fmt ff "@@";
|
||||||
|
fmt_ty ff t
|
||||||
|
|
||||||
|
| TY_mutable t ->
|
||||||
|
fmt ff "mutable ";
|
||||||
|
fmt_ty ff t
|
||||||
|
|
||||||
| TY_fn tfn -> fmt_ty_fn ff None tfn
|
| TY_fn tfn -> fmt_ty_fn ff None tfn
|
||||||
| TY_task -> fmt ff "task"
|
| TY_task -> fmt ff "task"
|
||||||
| TY_tag ttag -> fmt_tag ff ttag
|
| TY_tag ttag -> fmt_tag ff ttag
|
||||||
|
@ -964,7 +983,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
|
||||||
fmt_lval ff lv;
|
fmt_lval ff lv;
|
||||||
fmt ff " ";
|
fmt ff " ";
|
||||||
fmt_binop ff binop;
|
fmt_binop ff binop;
|
||||||
fmt ff "=";
|
fmt ff "= ";
|
||||||
fmt_atom ff at;
|
fmt_atom ff at;
|
||||||
fmt ff ";"
|
fmt ff ";"
|
||||||
|
|
||||||
|
@ -999,11 +1018,9 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
|
||||||
do
|
do
|
||||||
if i != 0
|
if i != 0
|
||||||
then fmt ff ", ";
|
then fmt ff ", ";
|
||||||
let (ident, mode, mut, atom) = entries.(i) in
|
let (ident, atom) = entries.(i) in
|
||||||
fmt_ident ff ident;
|
fmt_ident ff ident;
|
||||||
fmt ff " = ";
|
fmt ff " = ";
|
||||||
fmt_mutable ff mut;
|
|
||||||
fmt_mode ff mode;
|
|
||||||
fmt_atom ff atom;
|
fmt_atom ff atom;
|
||||||
done;
|
done;
|
||||||
begin
|
begin
|
||||||
|
@ -1015,7 +1032,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
|
||||||
end;
|
end;
|
||||||
fmt ff ");"
|
fmt ff ");"
|
||||||
|
|
||||||
| STMT_init_vec (dst, _, atoms) ->
|
| STMT_init_vec (dst, atoms) ->
|
||||||
fmt_lval ff dst;
|
fmt_lval ff dst;
|
||||||
fmt ff " = vec(";
|
fmt ff " = vec(";
|
||||||
for i = 0 to (Array.length atoms) - 1
|
for i = 0 to (Array.length atoms) - 1
|
||||||
|
@ -1033,10 +1050,7 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
|
||||||
do
|
do
|
||||||
if i != 0
|
if i != 0
|
||||||
then fmt ff ", ";
|
then fmt ff ", ";
|
||||||
let (mode, mut, atom) = entries.(i) in
|
fmt_atom ff entries.(i);
|
||||||
fmt_mutable ff mut;
|
|
||||||
fmt_mode ff mode;
|
|
||||||
fmt_atom ff atom;
|
|
||||||
done;
|
done;
|
||||||
fmt ff ");";
|
fmt ff ");";
|
||||||
|
|
||||||
|
@ -1153,6 +1167,12 @@ and fmt_stmt_body (ff:Format.formatter) (s:stmt) : unit =
|
||||||
fmt_lval ff t;
|
fmt_lval ff t;
|
||||||
fmt ff ";"
|
fmt ff ";"
|
||||||
|
|
||||||
|
| STMT_init_exterior (lv, at) ->
|
||||||
|
fmt_lval ff lv;
|
||||||
|
fmt ff " = @";
|
||||||
|
fmt_atom ff at;
|
||||||
|
fmt ff ";"
|
||||||
|
|
||||||
| STMT_alt_tag _ -> fmt ff "?stmt_alt_tag?"
|
| STMT_alt_tag _ -> fmt ff "?stmt_alt_tag?"
|
||||||
| STMT_alt_type _ -> fmt ff "?stmt_alt_type?"
|
| STMT_alt_type _ -> fmt ff "?stmt_alt_type?"
|
||||||
| STMT_alt_port _ -> fmt ff "?stmt_alt_port?"
|
| STMT_alt_port _ -> fmt ff "?stmt_alt_port?"
|
||||||
|
@ -1321,7 +1341,6 @@ let sprintf_lval_component = sprintf_fmt fmt_lval_component;;
|
||||||
let sprintf_atom = sprintf_fmt fmt_atom;;
|
let sprintf_atom = sprintf_fmt fmt_atom;;
|
||||||
let sprintf_slot = sprintf_fmt fmt_slot;;
|
let sprintf_slot = sprintf_fmt fmt_slot;;
|
||||||
let sprintf_slot_key = sprintf_fmt fmt_slot_key;;
|
let sprintf_slot_key = sprintf_fmt fmt_slot_key;;
|
||||||
let sprintf_mutable = sprintf_fmt fmt_mutable;;
|
|
||||||
let sprintf_ty = sprintf_fmt fmt_ty;;
|
let sprintf_ty = sprintf_fmt fmt_ty;;
|
||||||
let sprintf_effect = sprintf_fmt fmt_effect;;
|
let sprintf_effect = sprintf_fmt fmt_effect;;
|
||||||
let sprintf_tag = sprintf_fmt fmt_tag;;
|
let sprintf_tag = sprintf_fmt fmt_tag;;
|
||||||
|
|
|
@ -128,6 +128,13 @@ and parse_auto_slot_and_init
|
||||||
and parse_stmts (ps:pstate) : Ast.stmt array =
|
and parse_stmts (ps:pstate) : Ast.stmt array =
|
||||||
let apos = lexpos ps in
|
let apos = lexpos ps in
|
||||||
|
|
||||||
|
let ensure_mutable slot =
|
||||||
|
match slot.Ast.slot_ty with
|
||||||
|
None -> slot
|
||||||
|
| Some (Ast.TY_mutable _) -> slot
|
||||||
|
| Some t -> { slot with Ast.slot_ty = Some (Ast.TY_mutable t) }
|
||||||
|
in
|
||||||
|
|
||||||
let rec name_to_lval (apos:pos) (bpos:pos) (name:Ast.name)
|
let rec name_to_lval (apos:pos) (bpos:pos) (name:Ast.name)
|
||||||
: Ast.lval =
|
: Ast.lval =
|
||||||
match name with
|
match name with
|
||||||
|
@ -236,7 +243,6 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
|
||||||
Ast.NAME_base (Ast.BASE_ident ident) ->
|
Ast.NAME_base (Ast.BASE_ident ident) ->
|
||||||
let slot =
|
let slot =
|
||||||
{ Ast.slot_mode = Ast.MODE_interior;
|
{ Ast.slot_mode = Ast.MODE_interior;
|
||||||
Ast.slot_mutable = false;
|
|
||||||
Ast.slot_ty = None }
|
Ast.slot_ty = None }
|
||||||
in
|
in
|
||||||
Ast.PAT_slot
|
Ast.PAT_slot
|
||||||
|
@ -456,7 +462,7 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
|
||||||
bump ps;
|
bump ps;
|
||||||
let (stmts, slot, ident) =
|
let (stmts, slot, ident) =
|
||||||
ctxt "stmt slot" parse_slot_and_ident_and_init ps in
|
ctxt "stmt slot" parse_slot_and_ident_and_init ps in
|
||||||
let slot = Pexp.apply_mutability slot true in
|
let slot = ensure_mutable slot in
|
||||||
let bpos = lexpos ps in
|
let bpos = lexpos ps in
|
||||||
let decl = Ast.DECL_slot (Ast.KEY_ident ident,
|
let decl = Ast.DECL_slot (Ast.KEY_ident ident,
|
||||||
(span ps apos bpos slot))
|
(span ps apos bpos slot))
|
||||||
|
@ -467,7 +473,7 @@ and parse_stmts (ps:pstate) : Ast.stmt array =
|
||||||
bump ps;
|
bump ps;
|
||||||
let (stmts, slot, ident) =
|
let (stmts, slot, ident) =
|
||||||
ctxt "stmt slot" parse_auto_slot_and_init ps in
|
ctxt "stmt slot" parse_auto_slot_and_init ps in
|
||||||
let slot = Pexp.apply_mutability slot true in
|
let slot = ensure_mutable slot in
|
||||||
let bpos = lexpos ps in
|
let bpos = lexpos ps in
|
||||||
let decl = Ast.DECL_slot (Ast.KEY_ident ident,
|
let decl = Ast.DECL_slot (Ast.KEY_ident ident,
|
||||||
(span ps apos bpos slot))
|
(span ps apos bpos slot))
|
||||||
|
@ -979,7 +985,9 @@ and expand_tags
|
||||||
(ps, "unexpected name type while expanding tag"))
|
(ps, "unexpected name type while expanding tag"))
|
||||||
in
|
in
|
||||||
let header =
|
let header =
|
||||||
Array.map (fun slot -> (clone_span ps item slot)) tup
|
Array.map (fun ty -> (clone_span ps item
|
||||||
|
{ Ast.slot_mode = Ast.MODE_alias;
|
||||||
|
Ast.slot_ty = Some ty})) tup
|
||||||
in
|
in
|
||||||
let tag_item' = Ast.MOD_ITEM_tag (header, ttag, id) in
|
let tag_item' = Ast.MOD_ITEM_tag (header, ttag, id) in
|
||||||
let cloned_params =
|
let cloned_params =
|
||||||
|
|
|
@ -181,13 +181,11 @@ let err (str:string) (ps:pstate) =
|
||||||
|
|
||||||
let (slot_nil:Ast.slot) =
|
let (slot_nil:Ast.slot) =
|
||||||
{ Ast.slot_mode = Ast.MODE_interior;
|
{ Ast.slot_mode = Ast.MODE_interior;
|
||||||
Ast.slot_mutable = false;
|
|
||||||
Ast.slot_ty = Some Ast.TY_nil }
|
Ast.slot_ty = Some Ast.TY_nil }
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let (slot_auto:Ast.slot) =
|
let (slot_auto:Ast.slot) =
|
||||||
{ Ast.slot_mode = Ast.MODE_interior;
|
{ Ast.slot_mode = Ast.MODE_interior;
|
||||||
Ast.slot_mutable = true;
|
|
||||||
Ast.slot_ty = None }
|
Ast.slot_ty = None }
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
|
|
@ -22,7 +22,7 @@ type pexp' =
|
||||||
| PEXP_bind of (pexp * pexp option array)
|
| PEXP_bind of (pexp * pexp option array)
|
||||||
| PEXP_rec of ((Ast.ident * pexp) array * pexp option)
|
| PEXP_rec of ((Ast.ident * pexp) array * pexp option)
|
||||||
| PEXP_tup of (pexp array)
|
| PEXP_tup of (pexp array)
|
||||||
| PEXP_vec of (Ast.slot * (pexp array))
|
| PEXP_vec of (pexp array)
|
||||||
| PEXP_port
|
| PEXP_port
|
||||||
| PEXP_chan of (pexp option)
|
| PEXP_chan of (pexp option)
|
||||||
| PEXP_binop of (Ast.binop * pexp * pexp)
|
| PEXP_binop of (Ast.binop * pexp * pexp)
|
||||||
|
@ -261,11 +261,10 @@ and parse_atomic_ty (ps:pstate) : Ast.ty =
|
||||||
|
|
||||||
| VEC ->
|
| VEC ->
|
||||||
bump ps;
|
bump ps;
|
||||||
Ast.TY_vec (bracketed LBRACKET RBRACKET (parse_slot false) ps)
|
Ast.TY_vec (bracketed LBRACKET RBRACKET parse_ty ps)
|
||||||
|
|
||||||
| IDENT _ -> Ast.TY_named (parse_name ps)
|
| IDENT _ -> Ast.TY_named (parse_name ps)
|
||||||
|
|
||||||
|
|
||||||
| TAG ->
|
| TAG ->
|
||||||
bump ps;
|
bump ps;
|
||||||
let htab = Hashtbl.create 4 in
|
let htab = Hashtbl.create 4 in
|
||||||
|
@ -273,7 +272,7 @@ and parse_atomic_ty (ps:pstate) : Ast.ty =
|
||||||
let ident = parse_ident ps in
|
let ident = parse_ident ps in
|
||||||
let tup =
|
let tup =
|
||||||
match peek ps with
|
match peek ps with
|
||||||
LPAREN -> paren_comma_list (parse_slot false) ps
|
LPAREN -> paren_comma_list parse_ty ps
|
||||||
| _ -> raise (err "tag variant missing argument list" ps)
|
| _ -> raise (err "tag variant missing argument list" ps)
|
||||||
in
|
in
|
||||||
htab_put htab (Ast.NAME_base (Ast.BASE_ident ident)) tup
|
htab_put htab (Ast.NAME_base (Ast.BASE_ident ident)) tup
|
||||||
|
@ -287,9 +286,8 @@ and parse_atomic_ty (ps:pstate) : Ast.ty =
|
||||||
| REC ->
|
| REC ->
|
||||||
bump ps;
|
bump ps;
|
||||||
let parse_rec_entry ps =
|
let parse_rec_entry ps =
|
||||||
let mut = parse_mutability ps in
|
let (ty, ident) = parse_ty_and_ident ps in
|
||||||
let (slot, ident) = parse_slot_and_ident false ps in
|
(ident, ty)
|
||||||
(ident, apply_mutability slot mut)
|
|
||||||
in
|
in
|
||||||
let entries = paren_comma_list parse_rec_entry ps in
|
let entries = paren_comma_list parse_rec_entry ps in
|
||||||
let labels = Array.map (fun (l, _) -> l) entries in
|
let labels = Array.map (fun (l, _) -> l) entries in
|
||||||
|
@ -300,8 +298,8 @@ and parse_atomic_ty (ps:pstate) : Ast.ty =
|
||||||
|
|
||||||
| TUP ->
|
| TUP ->
|
||||||
bump ps;
|
bump ps;
|
||||||
let slots = paren_comma_list (parse_slot false) ps in
|
let tys = paren_comma_list parse_ty ps in
|
||||||
Ast.TY_tup slots
|
Ast.TY_tup tys
|
||||||
|
|
||||||
| MACH m ->
|
| MACH m ->
|
||||||
bump ps;
|
bump ps;
|
||||||
|
@ -333,6 +331,14 @@ and parse_atomic_ty (ps:pstate) : Ast.ty =
|
||||||
| _ -> raise (unexpected ps)
|
| _ -> raise (unexpected ps)
|
||||||
end
|
end
|
||||||
|
|
||||||
|
| AT ->
|
||||||
|
bump ps;
|
||||||
|
Ast.TY_exterior (parse_ty ps)
|
||||||
|
|
||||||
|
| MUTABLE ->
|
||||||
|
bump ps;
|
||||||
|
Ast.TY_mutable (parse_ty ps)
|
||||||
|
|
||||||
| LPAREN ->
|
| LPAREN ->
|
||||||
begin
|
begin
|
||||||
bump ps;
|
bump ps;
|
||||||
|
@ -356,21 +362,15 @@ and flag (ps:pstate) (tok:token) : bool =
|
||||||
and parse_mutability (ps:pstate) : bool =
|
and parse_mutability (ps:pstate) : bool =
|
||||||
flag ps MUTABLE
|
flag ps MUTABLE
|
||||||
|
|
||||||
and apply_mutability (slot:Ast.slot) (mut:bool) : Ast.slot =
|
|
||||||
{ slot with Ast.slot_mutable = mut }
|
|
||||||
|
|
||||||
and parse_slot (aliases_ok:bool) (ps:pstate) : Ast.slot =
|
and parse_slot (aliases_ok:bool) (ps:pstate) : Ast.slot =
|
||||||
let mut = parse_mutability ps in
|
|
||||||
let mode =
|
let mode =
|
||||||
match (peek ps, aliases_ok) with
|
match (peek ps, aliases_ok) with
|
||||||
(AT, _) -> bump ps; Ast.MODE_exterior
|
(AND, true) -> bump ps; Ast.MODE_alias
|
||||||
| (AND, true) -> bump ps; Ast.MODE_alias
|
|
||||||
| (AND, false) -> raise (err "alias slot in prohibited context" ps)
|
| (AND, false) -> raise (err "alias slot in prohibited context" ps)
|
||||||
| _ -> Ast.MODE_interior
|
| _ -> Ast.MODE_interior
|
||||||
in
|
in
|
||||||
let ty = parse_ty ps in
|
let ty = parse_ty ps in
|
||||||
{ Ast.slot_mode = mode;
|
{ Ast.slot_mode = mode;
|
||||||
Ast.slot_mutable = mut;
|
|
||||||
Ast.slot_ty = Some ty }
|
Ast.slot_ty = Some ty }
|
||||||
|
|
||||||
and parse_slot_and_ident
|
and parse_slot_and_ident
|
||||||
|
@ -381,6 +381,13 @@ and parse_slot_and_ident
|
||||||
let ident = ctxt "slot and ident: ident" parse_ident ps in
|
let ident = ctxt "slot and ident: ident" parse_ident ps in
|
||||||
(slot, ident)
|
(slot, ident)
|
||||||
|
|
||||||
|
and parse_ty_and_ident
|
||||||
|
(ps:pstate)
|
||||||
|
: (Ast.ty * Ast.ident) =
|
||||||
|
let ty = ctxt "ty and ident: ty" parse_ty ps in
|
||||||
|
let ident = ctxt "ty and ident: ident" parse_ident ps in
|
||||||
|
(ty, ident)
|
||||||
|
|
||||||
and parse_slot_and_optional_ignored_ident
|
and parse_slot_and_optional_ignored_ident
|
||||||
(aliases_ok:bool)
|
(aliases_ok:bool)
|
||||||
(ps:pstate)
|
(ps:pstate)
|
||||||
|
@ -494,16 +501,9 @@ and parse_bottom_pexp (ps:pstate) : pexp =
|
||||||
| VEC ->
|
| VEC ->
|
||||||
bump ps;
|
bump ps;
|
||||||
begin
|
begin
|
||||||
let slot =
|
|
||||||
match peek ps with
|
|
||||||
LBRACKET -> bracketed LBRACKET RBRACKET (parse_slot false) ps
|
|
||||||
| _ -> { Ast.slot_mode = Ast.MODE_interior;
|
|
||||||
Ast.slot_mutable = false;
|
|
||||||
Ast.slot_ty = None }
|
|
||||||
in
|
|
||||||
let pexps = ctxt "vec pexp: exprs" parse_pexp_list ps in
|
let pexps = ctxt "vec pexp: exprs" parse_pexp_list ps in
|
||||||
let bpos = lexpos ps in
|
let bpos = lexpos ps in
|
||||||
span ps apos bpos (PEXP_vec (slot, pexps))
|
span ps apos bpos (PEXP_vec pexps)
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
|
@ -1088,7 +1088,9 @@ and desugar_expr_atom
|
||||||
| PEXP_call _
|
| PEXP_call _
|
||||||
| PEXP_bind _
|
| PEXP_bind _
|
||||||
| PEXP_spawn _
|
| PEXP_spawn _
|
||||||
| PEXP_custom _ ->
|
| PEXP_custom _
|
||||||
|
| PEXP_exterior _
|
||||||
|
| PEXP_mutable _ ->
|
||||||
let (_, tmp, decl_stmt) = build_tmp ps slot_auto apos bpos in
|
let (_, tmp, decl_stmt) = build_tmp ps slot_auto apos bpos in
|
||||||
let stmts = desugar_expr_init ps tmp pexp in
|
let stmts = desugar_expr_init ps tmp pexp in
|
||||||
(Array.append [| decl_stmt |] stmts,
|
(Array.append [| decl_stmt |] stmts,
|
||||||
|
@ -1101,31 +1103,6 @@ and desugar_expr_atom
|
||||||
let (stmts, lval) = desugar_lval ps pexp in
|
let (stmts, lval) = desugar_lval ps pexp in
|
||||||
(stmts, Ast.ATOM_lval lval)
|
(stmts, Ast.ATOM_lval lval)
|
||||||
|
|
||||||
| PEXP_exterior _ ->
|
|
||||||
raise (err "exterior symbol in atom context" ps)
|
|
||||||
|
|
||||||
| PEXP_mutable _ ->
|
|
||||||
raise (err "mutable keyword in atom context" ps)
|
|
||||||
|
|
||||||
|
|
||||||
and desugar_expr_mode_mut_atom
|
|
||||||
(ps:pstate)
|
|
||||||
(pexp:pexp)
|
|
||||||
: (Ast.stmt array * (Ast.mode * bool * Ast.atom)) =
|
|
||||||
let desugar_inner mode mut e =
|
|
||||||
let (stmts, atom) = desugar_expr_atom ps e in
|
|
||||||
(stmts, (mode, mut, atom))
|
|
||||||
in
|
|
||||||
match pexp.node with
|
|
||||||
PEXP_mutable {node=(PEXP_exterior e); id=_} ->
|
|
||||||
desugar_inner Ast.MODE_exterior true e
|
|
||||||
| PEXP_exterior e ->
|
|
||||||
desugar_inner Ast.MODE_exterior false e
|
|
||||||
| PEXP_mutable e ->
|
|
||||||
desugar_inner Ast.MODE_interior true e
|
|
||||||
| _ ->
|
|
||||||
desugar_inner Ast.MODE_interior false pexp
|
|
||||||
|
|
||||||
and desugar_expr_atoms
|
and desugar_expr_atoms
|
||||||
(ps:pstate)
|
(ps:pstate)
|
||||||
(pexps:pexp array)
|
(pexps:pexp array)
|
||||||
|
@ -1138,12 +1115,6 @@ and desugar_opt_expr_atoms
|
||||||
: (Ast.stmt array * Ast.atom option array) =
|
: (Ast.stmt array * Ast.atom option array) =
|
||||||
arj1st (Array.map (desugar_opt_expr_atom ps) pexps)
|
arj1st (Array.map (desugar_opt_expr_atom ps) pexps)
|
||||||
|
|
||||||
and desugar_expr_mode_mut_atoms
|
|
||||||
(ps:pstate)
|
|
||||||
(pexps:pexp array)
|
|
||||||
: (Ast.stmt array * (Ast.mode * bool * Ast.atom) array) =
|
|
||||||
arj1st (Array.map (desugar_expr_mode_mut_atom ps) pexps)
|
|
||||||
|
|
||||||
and desugar_expr_init
|
and desugar_expr_init
|
||||||
(ps:pstate)
|
(ps:pstate)
|
||||||
(dst_lval:Ast.lval)
|
(dst_lval:Ast.lval)
|
||||||
|
@ -1253,10 +1224,10 @@ and desugar_expr_init
|
||||||
Array.map
|
Array.map
|
||||||
begin
|
begin
|
||||||
fun (ident, pexp) ->
|
fun (ident, pexp) ->
|
||||||
let (stmts, (mode, mut, atom)) =
|
let (stmts, atom) =
|
||||||
desugar_expr_mode_mut_atom ps pexp
|
desugar_expr_atom ps pexp
|
||||||
in
|
in
|
||||||
(stmts, (ident, mode, mut, atom))
|
(stmts, (ident, atom))
|
||||||
end
|
end
|
||||||
args
|
args
|
||||||
end
|
end
|
||||||
|
@ -1278,19 +1249,19 @@ and desugar_expr_init
|
||||||
end
|
end
|
||||||
|
|
||||||
| PEXP_tup args ->
|
| PEXP_tup args ->
|
||||||
let (arg_stmts, arg_mode_atoms) =
|
let (arg_stmts, arg_atoms) =
|
||||||
desugar_expr_mode_mut_atoms ps args
|
desugar_expr_atoms ps args
|
||||||
in
|
in
|
||||||
let stmt = ss (Ast.STMT_init_tup (dst_lval, arg_mode_atoms)) in
|
let stmt = ss (Ast.STMT_init_tup (dst_lval, arg_atoms)) in
|
||||||
aa arg_stmts [| stmt |]
|
aa arg_stmts [| stmt |]
|
||||||
|
|
||||||
| PEXP_str s ->
|
| PEXP_str s ->
|
||||||
let stmt = ss (Ast.STMT_init_str (dst_lval, s)) in
|
let stmt = ss (Ast.STMT_init_str (dst_lval, s)) in
|
||||||
[| stmt |]
|
[| stmt |]
|
||||||
|
|
||||||
| PEXP_vec (slot, args) ->
|
| PEXP_vec args ->
|
||||||
let (arg_stmts, arg_atoms) = desugar_expr_atoms ps args in
|
let (arg_stmts, arg_atoms) = desugar_expr_atoms ps args in
|
||||||
let stmt = ss (Ast.STMT_init_vec (dst_lval, slot, arg_atoms)) in
|
let stmt = ss (Ast.STMT_init_vec (dst_lval, arg_atoms)) in
|
||||||
aa arg_stmts [| stmt |]
|
aa arg_stmts [| stmt |]
|
||||||
|
|
||||||
| PEXP_port ->
|
| PEXP_port ->
|
||||||
|
@ -1315,11 +1286,19 @@ and desugar_expr_init
|
||||||
in
|
in
|
||||||
aa port_stmts [| chan_stmt |]
|
aa port_stmts [| chan_stmt |]
|
||||||
|
|
||||||
| PEXP_exterior _ ->
|
| PEXP_exterior arg ->
|
||||||
raise (err "exterior symbol in initialiser context" ps)
|
let (arg_stmts, arg_mode_atom) =
|
||||||
|
desugar_expr_atom ps arg
|
||||||
|
in
|
||||||
|
let stmt = ss (Ast.STMT_init_exterior (dst_lval, arg_mode_atom)) in
|
||||||
|
aa arg_stmts [| stmt |]
|
||||||
|
|
||||||
| PEXP_mutable _ ->
|
| PEXP_mutable arg ->
|
||||||
raise (err "mutable keyword in initialiser context" ps)
|
(* Initializing a local from a "mutable" atom is the same as
|
||||||
|
* initializing it from an immutable one; all locals are mutable
|
||||||
|
* anyways. So this is just a fall-through.
|
||||||
|
*)
|
||||||
|
desugar_expr_init ps dst_lval arg
|
||||||
|
|
||||||
| PEXP_custom (n, a, b) ->
|
| PEXP_custom (n, a, b) ->
|
||||||
let (arg_stmts, args) = desugar_expr_atoms ps a in
|
let (arg_stmts, args) = desugar_expr_atoms ps a in
|
||||||
|
|
|
@ -67,7 +67,7 @@ let alias_analysis_visitor
|
||||||
| Ast.STMT_recv (dst, _) -> alias dst
|
| Ast.STMT_recv (dst, _) -> alias dst
|
||||||
| Ast.STMT_init_port (dst) -> alias dst
|
| Ast.STMT_init_port (dst) -> alias dst
|
||||||
| Ast.STMT_init_chan (dst, _) -> alias dst
|
| Ast.STMT_init_chan (dst, _) -> alias dst
|
||||||
| Ast.STMT_init_vec (dst, _, _) -> alias dst
|
| Ast.STMT_init_vec (dst, _) -> alias dst
|
||||||
| Ast.STMT_init_str (dst, _) -> alias dst
|
| Ast.STMT_init_str (dst, _) -> alias dst
|
||||||
| Ast.STMT_for_each sfe ->
|
| Ast.STMT_for_each sfe ->
|
||||||
let (slot, _) = sfe.Ast.for_each_slot in
|
let (slot, _) = sfe.Ast.for_each_slot in
|
||||||
|
|
|
@ -1305,58 +1305,67 @@ let (abbrev_base_type:abbrev) =
|
||||||
|
|
||||||
let (abbrev_alias_slot:abbrev) =
|
let (abbrev_alias_slot:abbrev) =
|
||||||
(DW_TAG_reference_type, DW_CHILDREN_no,
|
(DW_TAG_reference_type, DW_CHILDREN_no,
|
||||||
|
[|
|
||||||
|
(DW_AT_type, DW_FORM_ref_addr);
|
||||||
|
|])
|
||||||
|
;;
|
||||||
|
|
||||||
|
(* FIXME: Perverse, but given dwarf's vocabulary it seems at least plausible
|
||||||
|
* that a "mutable const type" is a correct way of saying "mutable". Or else we
|
||||||
|
* make up our own. Revisit perhaps.
|
||||||
|
*)
|
||||||
|
let (abbrev_mutable_type:abbrev) =
|
||||||
|
(DW_TAG_const_type, DW_CHILDREN_no,
|
||||||
[|
|
[|
|
||||||
(DW_AT_type, DW_FORM_ref_addr);
|
(DW_AT_type, DW_FORM_ref_addr);
|
||||||
(DW_AT_mutable, DW_FORM_flag);
|
(DW_AT_mutable, DW_FORM_flag);
|
||||||
|])
|
|])
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let (abbrev_exterior_slot:abbrev) =
|
let (abbrev_exterior_type:abbrev) =
|
||||||
(DW_TAG_reference_type, DW_CHILDREN_no,
|
(DW_TAG_pointer_type, DW_CHILDREN_no,
|
||||||
[|
|
[|
|
||||||
(DW_AT_type, DW_FORM_ref_addr);
|
(DW_AT_type, DW_FORM_ref_addr);
|
||||||
(DW_AT_mutable, DW_FORM_flag);
|
|
||||||
(DW_AT_data_location, DW_FORM_block1);
|
(DW_AT_data_location, DW_FORM_block1);
|
||||||
|])
|
|])
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let (abbrev_struct_type:abbrev) =
|
let (abbrev_struct_type:abbrev) =
|
||||||
(DW_TAG_structure_type, DW_CHILDREN_yes,
|
(DW_TAG_structure_type, DW_CHILDREN_yes,
|
||||||
[|
|
[|
|
||||||
(DW_AT_byte_size, DW_FORM_block4)
|
(DW_AT_byte_size, DW_FORM_block4)
|
||||||
|])
|
|])
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let (abbrev_struct_type_member:abbrev) =
|
let (abbrev_struct_type_member:abbrev) =
|
||||||
(DW_TAG_member, DW_CHILDREN_no,
|
(DW_TAG_member, DW_CHILDREN_no,
|
||||||
[|
|
[|
|
||||||
(DW_AT_name, DW_FORM_string);
|
(DW_AT_name, DW_FORM_string);
|
||||||
(DW_AT_type, DW_FORM_ref_addr);
|
(DW_AT_type, DW_FORM_ref_addr);
|
||||||
(DW_AT_mutable, DW_FORM_flag);
|
(DW_AT_data_member_location, DW_FORM_block4);
|
||||||
(DW_AT_data_member_location, DW_FORM_block4);
|
(DW_AT_byte_size, DW_FORM_block4)
|
||||||
(DW_AT_byte_size, DW_FORM_block4)
|
|])
|
||||||
|])
|
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let (abbrev_variant_part:abbrev) =
|
let (abbrev_variant_part:abbrev) =
|
||||||
(DW_TAG_variant_part, DW_CHILDREN_yes,
|
(DW_TAG_variant_part, DW_CHILDREN_yes,
|
||||||
[|
|
[|
|
||||||
(DW_AT_discr, DW_FORM_ref_addr)
|
(DW_AT_discr, DW_FORM_ref_addr)
|
||||||
|])
|
|])
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
|
||||||
let (abbrev_variant:abbrev) =
|
let (abbrev_variant:abbrev) =
|
||||||
(DW_TAG_variant, DW_CHILDREN_yes,
|
(DW_TAG_variant, DW_CHILDREN_yes,
|
||||||
[|
|
[|
|
||||||
(DW_AT_discr_value, DW_FORM_udata)
|
(DW_AT_discr_value, DW_FORM_udata)
|
||||||
|])
|
|])
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let (abbrev_subroutine_type:abbrev) =
|
let (abbrev_subroutine_type:abbrev) =
|
||||||
(DW_TAG_subroutine_type, DW_CHILDREN_yes,
|
(DW_TAG_subroutine_type, DW_CHILDREN_yes,
|
||||||
[|
|
[|
|
||||||
(DW_AT_type, DW_FORM_ref_addr); (* NB: output type. *)
|
(DW_AT_type, DW_FORM_ref_addr); (* NB: output type. *)
|
||||||
(DW_AT_mutable, DW_FORM_flag);
|
(DW_AT_mutable, DW_FORM_flag);
|
||||||
(DW_AT_pure, DW_FORM_flag);
|
(DW_AT_pure, DW_FORM_flag);
|
||||||
(DW_AT_rust_iterator, DW_FORM_flag);
|
(DW_AT_rust_iterator, DW_FORM_flag);
|
||||||
|
@ -1541,33 +1550,8 @@ let dwarf_visitor
|
||||||
in
|
in
|
||||||
|
|
||||||
match slot.Ast.slot_mode with
|
match slot.Ast.slot_mode with
|
||||||
Ast.MODE_exterior ->
|
| Ast.MODE_interior ->
|
||||||
let fix = new_fixup "exterior DIE" in
|
ref_type_die (slot_ty slot)
|
||||||
let body_off =
|
|
||||||
word_sz_int * Abi.exterior_rc_slot_field_body
|
|
||||||
in
|
|
||||||
emit_die (DEF (fix, SEQ [|
|
|
||||||
uleb (get_abbrev_code abbrev_exterior_slot);
|
|
||||||
(* DW_AT_type: DW_FORM_ref_addr *)
|
|
||||||
(ref_type_die (slot_ty slot));
|
|
||||||
(* DW_AT_mutable: DW_FORM_flag *)
|
|
||||||
BYTE (if slot.Ast.slot_mutable
|
|
||||||
then 1 else 0);
|
|
||||||
(* DW_AT_data_location: DW_FORM_block1 *)
|
|
||||||
(* This is a DWARF expression for moving
|
|
||||||
from the address of an exterior
|
|
||||||
allocation to the address of its
|
|
||||||
body. *)
|
|
||||||
dw_form_block1
|
|
||||||
[| DW_OP_push_object_address;
|
|
||||||
DW_OP_lit body_off;
|
|
||||||
DW_OP_plus;
|
|
||||||
DW_OP_deref |]
|
|
||||||
|]));
|
|
||||||
ref_addr_for_fix fix
|
|
||||||
|
|
||||||
(* FIXME (issue #72): encode mutable-ness of interiors. *)
|
|
||||||
| Ast.MODE_interior -> ref_type_die (slot_ty slot)
|
|
||||||
|
|
||||||
| Ast.MODE_alias ->
|
| Ast.MODE_alias ->
|
||||||
let fix = new_fixup "alias DIE" in
|
let fix = new_fixup "alias DIE" in
|
||||||
|
@ -1575,8 +1559,6 @@ let dwarf_visitor
|
||||||
uleb (get_abbrev_code abbrev_alias_slot);
|
uleb (get_abbrev_code abbrev_alias_slot);
|
||||||
(* DW_AT_type: DW_FORM_ref_addr *)
|
(* DW_AT_type: DW_FORM_ref_addr *)
|
||||||
(ref_type_die (slot_ty slot));
|
(ref_type_die (slot_ty slot));
|
||||||
(* DW_AT_mutable: DW_FORM_flag *)
|
|
||||||
BYTE (if slot.Ast.slot_mutable then 1 else 0)
|
|
||||||
|]));
|
|]));
|
||||||
ref_addr_for_fix fix
|
ref_addr_for_fix fix
|
||||||
|
|
||||||
|
@ -1708,15 +1690,13 @@ let dwarf_visitor
|
||||||
emit_die die;
|
emit_die die;
|
||||||
Array.iteri
|
Array.iteri
|
||||||
begin
|
begin
|
||||||
fun i (ident, slot) ->
|
fun i (ident, ty) ->
|
||||||
emit_die (SEQ [|
|
emit_die (SEQ [|
|
||||||
uleb (get_abbrev_code abbrev_struct_type_member);
|
uleb (get_abbrev_code abbrev_struct_type_member);
|
||||||
(* DW_AT_name: DW_FORM_string *)
|
(* DW_AT_name: DW_FORM_string *)
|
||||||
ZSTRING ident;
|
ZSTRING ident;
|
||||||
(* DW_AT_type: DW_FORM_ref_addr *)
|
(* DW_AT_type: DW_FORM_ref_addr *)
|
||||||
(ref_slot_die slot);
|
(ref_type_die ty);
|
||||||
(* DW_AT_mutable: DW_FORM_flag *)
|
|
||||||
BYTE (if slot.Ast.slot_mutable then 1 else 0);
|
|
||||||
(* DW_AT_data_member_location: DW_FORM_block4 *)
|
(* DW_AT_data_member_location: DW_FORM_block4 *)
|
||||||
size_block4
|
size_block4
|
||||||
(Il.get_element_offset word_bits rtys i)
|
(Il.get_element_offset word_bits rtys i)
|
||||||
|
@ -1904,10 +1884,6 @@ let dwarf_visitor
|
||||||
unspecified_ptr_with_ref rust_ty (ref_type_die ty)
|
unspecified_ptr_with_ref rust_ty (ref_type_die ty)
|
||||||
in
|
in
|
||||||
|
|
||||||
let unspecified_ptr_with_ref_slot rust_ty slot =
|
|
||||||
unspecified_ptr_with_ref rust_ty (ref_slot_die slot)
|
|
||||||
in
|
|
||||||
|
|
||||||
let unspecified_ptr rust_ty =
|
let unspecified_ptr rust_ty =
|
||||||
unspecified_ptr_with_ref rust_ty (unspecified_anon_struct ())
|
unspecified_ptr_with_ref rust_ty (unspecified_anon_struct ())
|
||||||
in
|
in
|
||||||
|
@ -1974,9 +1950,7 @@ let dwarf_visitor
|
||||||
(* DW_AT_name: DW_FORM_string *)
|
(* DW_AT_name: DW_FORM_string *)
|
||||||
ZSTRING "tag";
|
ZSTRING "tag";
|
||||||
(* DW_AT_type: DW_FORM_ref_addr *)
|
(* DW_AT_type: DW_FORM_ref_addr *)
|
||||||
(ref_slot_die (interior_slot Ast.TY_uint));
|
(ref_type_die Ast.TY_uint);
|
||||||
(* DW_AT_mutable: DW_FORM_flag *)
|
|
||||||
BYTE 0;
|
|
||||||
(* DW_AT_data_member_location: DW_FORM_block4 *)
|
(* DW_AT_data_member_location: DW_FORM_block4 *)
|
||||||
size_block4
|
size_block4
|
||||||
(Il.get_element_offset word_bits rtys 0)
|
(Il.get_element_offset word_bits rtys 0)
|
||||||
|
@ -2038,6 +2012,41 @@ let dwarf_visitor
|
||||||
ref_addr_for_fix (Stack.top iso_stack).(i)
|
ref_addr_for_fix (Stack.top iso_stack).(i)
|
||||||
in
|
in
|
||||||
|
|
||||||
|
let exterior_type t =
|
||||||
|
let fix = new_fixup "exterior DIE" in
|
||||||
|
let body_off =
|
||||||
|
word_sz_int * Abi.exterior_rc_slot_field_body
|
||||||
|
in
|
||||||
|
emit_die (DEF (fix, SEQ [|
|
||||||
|
uleb (get_abbrev_code abbrev_exterior_type);
|
||||||
|
(* DW_AT_type: DW_FORM_ref_addr *)
|
||||||
|
(ref_type_die t);
|
||||||
|
(* DW_AT_data_location: DW_FORM_block1 *)
|
||||||
|
(* This is a DWARF expression for moving
|
||||||
|
from the address of an exterior
|
||||||
|
allocation to the address of its
|
||||||
|
body. *)
|
||||||
|
dw_form_block1
|
||||||
|
[| DW_OP_push_object_address;
|
||||||
|
DW_OP_lit body_off;
|
||||||
|
DW_OP_plus;
|
||||||
|
DW_OP_deref |]
|
||||||
|
|]));
|
||||||
|
ref_addr_for_fix fix
|
||||||
|
in
|
||||||
|
|
||||||
|
let mutable_type t =
|
||||||
|
let fix = new_fixup "mutable DIE" in
|
||||||
|
emit_die (DEF (fix, SEQ [|
|
||||||
|
uleb (get_abbrev_code abbrev_mutable_type);
|
||||||
|
(* DW_AT_type: DW_FORM_ref_addr *)
|
||||||
|
(ref_type_die t);
|
||||||
|
(* DW_AT_mutable: DW_FORM_flag *)
|
||||||
|
BYTE 1;
|
||||||
|
|]));
|
||||||
|
ref_addr_for_fix fix
|
||||||
|
in
|
||||||
|
|
||||||
match ty with
|
match ty with
|
||||||
Ast.TY_nil -> unspecified_struct DW_RUST_nil
|
Ast.TY_nil -> unspecified_struct DW_RUST_nil
|
||||||
| Ast.TY_bool -> base ("bool", DW_ATE_boolean, 1)
|
| Ast.TY_bool -> base ("bool", DW_ATE_boolean, 1)
|
||||||
|
@ -2058,7 +2067,7 @@ let dwarf_visitor
|
||||||
| Ast.TY_tag ttag -> tag_type None ttag
|
| Ast.TY_tag ttag -> tag_type None ttag
|
||||||
| Ast.TY_iso tiso -> iso_type tiso
|
| Ast.TY_iso tiso -> iso_type tiso
|
||||||
| Ast.TY_idx i -> idx_type i
|
| Ast.TY_idx i -> idx_type i
|
||||||
| Ast.TY_vec s -> unspecified_ptr_with_ref_slot DW_RUST_vec s
|
| Ast.TY_vec t -> unspecified_ptr_with_ref_ty DW_RUST_vec t
|
||||||
| Ast.TY_chan t -> unspecified_ptr_with_ref_ty DW_RUST_chan t
|
| Ast.TY_chan t -> unspecified_ptr_with_ref_ty DW_RUST_chan t
|
||||||
| Ast.TY_port t -> unspecified_ptr_with_ref_ty DW_RUST_port t
|
| Ast.TY_port t -> unspecified_ptr_with_ref_ty DW_RUST_port t
|
||||||
| Ast.TY_task -> unspecified_ptr DW_RUST_task
|
| Ast.TY_task -> unspecified_ptr DW_RUST_task
|
||||||
|
@ -2067,6 +2076,8 @@ let dwarf_visitor
|
||||||
| Ast.TY_native i -> native_ptr_type i
|
| Ast.TY_native i -> native_ptr_type i
|
||||||
| Ast.TY_param p -> rust_type_param p
|
| Ast.TY_param p -> rust_type_param p
|
||||||
| Ast.TY_obj ob -> obj_type ob
|
| Ast.TY_obj ob -> obj_type ob
|
||||||
|
| Ast.TY_mutable t -> mutable_type t
|
||||||
|
| Ast.TY_exterior t -> exterior_type t
|
||||||
| _ ->
|
| _ ->
|
||||||
bug () "unimplemented dwarf encoding for type %a"
|
bug () "unimplemented dwarf encoding for type %a"
|
||||||
Ast.sprintf_ty ty
|
Ast.sprintf_ty ty
|
||||||
|
@ -2893,7 +2904,7 @@ let rec extract_mod_items
|
||||||
|
|
||||||
| DW_TAG_pointer_type
|
| DW_TAG_pointer_type
|
||||||
when is_rust_type die DW_RUST_vec ->
|
when is_rust_type die DW_RUST_vec ->
|
||||||
Ast.TY_vec (get_referenced_slot die)
|
Ast.TY_vec (get_referenced_ty die)
|
||||||
|
|
||||||
| DW_TAG_pointer_type
|
| DW_TAG_pointer_type
|
||||||
when is_rust_type die DW_RUST_type_param ->
|
when is_rust_type die DW_RUST_type_param ->
|
||||||
|
@ -2903,6 +2914,13 @@ let rec extract_mod_items
|
||||||
when is_rust_type die DW_RUST_native ->
|
when is_rust_type die DW_RUST_native ->
|
||||||
Ast.TY_native (get_opaque_of (get_native_id die))
|
Ast.TY_native (get_opaque_of (get_native_id die))
|
||||||
|
|
||||||
|
| DW_TAG_pointer_type ->
|
||||||
|
Ast.TY_exterior (get_referenced_ty die)
|
||||||
|
|
||||||
|
| DW_TAG_const_type
|
||||||
|
when ((get_num die DW_AT_mutable) = 1) ->
|
||||||
|
Ast.TY_mutable (get_referenced_ty die)
|
||||||
|
|
||||||
| DW_TAG_string_type -> Ast.TY_str
|
| DW_TAG_string_type -> Ast.TY_str
|
||||||
|
|
||||||
| DW_TAG_base_type ->
|
| DW_TAG_base_type ->
|
||||||
|
@ -2953,13 +2971,13 @@ let rec extract_mod_items
|
||||||
assert ((Array.length members) > 0);
|
assert ((Array.length members) > 0);
|
||||||
if is_num_idx (get_name members.(0))
|
if is_num_idx (get_name members.(0))
|
||||||
then
|
then
|
||||||
let slots = Array.map get_referenced_slot members in
|
let tys = Array.map get_referenced_ty members in
|
||||||
Ast.TY_tup slots
|
Ast.TY_tup tys
|
||||||
else
|
else
|
||||||
let entries =
|
let entries =
|
||||||
Array.map
|
Array.map
|
||||||
(fun member_die -> ((get_name member_die),
|
(fun member_die -> ((get_name member_die),
|
||||||
(get_referenced_slot member_die)))
|
(get_referenced_ty member_die)))
|
||||||
members
|
members
|
||||||
in
|
in
|
||||||
Ast.TY_rec entries
|
Ast.TY_rec entries
|
||||||
|
@ -2989,23 +3007,11 @@ let rec extract_mod_items
|
||||||
match die.die_tag with
|
match die.die_tag with
|
||||||
DW_TAG_reference_type ->
|
DW_TAG_reference_type ->
|
||||||
let ty = get_referenced_ty die in
|
let ty = get_referenced_ty die in
|
||||||
let mut = get_flag die DW_AT_mutable in
|
{ Ast.slot_mode = Ast.MODE_alias;
|
||||||
let mode =
|
|
||||||
(* Exterior slots have a 'data_location' attr. *)
|
|
||||||
match atab_search die.die_attrs DW_AT_data_location with
|
|
||||||
Some _ -> Ast.MODE_exterior
|
|
||||||
| None -> Ast.MODE_alias
|
|
||||||
in
|
|
||||||
{ Ast.slot_mode = mode;
|
|
||||||
Ast.slot_mutable = mut;
|
|
||||||
Ast.slot_ty = Some ty }
|
Ast.slot_ty = Some ty }
|
||||||
| _ ->
|
| _ ->
|
||||||
let ty = get_ty die in
|
let ty = get_ty die in
|
||||||
(* FIXME (issue #28): encode mutability of interior slots
|
|
||||||
* properly.
|
|
||||||
*)
|
|
||||||
{ Ast.slot_mode = Ast.MODE_interior;
|
{ Ast.slot_mode = Ast.MODE_interior;
|
||||||
Ast.slot_mutable = false;
|
|
||||||
Ast.slot_ty = Some ty }
|
Ast.slot_ty = Some ty }
|
||||||
|
|
||||||
and get_referenced_ty die =
|
and get_referenced_ty die =
|
||||||
|
|
|
@ -33,12 +33,18 @@ let mutability_checking_visitor
|
||||||
| _ -> ()
|
| _ -> ()
|
||||||
in
|
in
|
||||||
|
|
||||||
let check_write id dst =
|
let check_write s dst =
|
||||||
let dst_slot = lval_slot cx dst in
|
let dst_ty = lval_ty cx dst in
|
||||||
if (dst_slot.Ast.slot_mutable or
|
let is_mutable =
|
||||||
(Hashtbl.mem cx.ctxt_copy_stmt_is_init id))
|
match dst_ty with
|
||||||
|
Ast.TY_mutable _ -> true
|
||||||
|
| _ -> false
|
||||||
|
in
|
||||||
|
if (is_mutable or (Hashtbl.mem cx.ctxt_copy_stmt_is_init s.id))
|
||||||
then ()
|
then ()
|
||||||
else err (Some id) "writing to non-mutable slot"
|
else err (Some s.id)
|
||||||
|
"writing to non-mutable slot of type %a in statement %a"
|
||||||
|
Ast.sprintf_ty dst_ty Ast.sprintf_stmt s
|
||||||
in
|
in
|
||||||
(* FIXME (issue #75): enforce the no-write-alias-to-immutable-slot
|
(* FIXME (issue #75): enforce the no-write-alias-to-immutable-slot
|
||||||
* rule.
|
* rule.
|
||||||
|
@ -46,10 +52,10 @@ let mutability_checking_visitor
|
||||||
let visit_stmt_pre s =
|
let visit_stmt_pre s =
|
||||||
begin
|
begin
|
||||||
match s.node with
|
match s.node with
|
||||||
Ast.STMT_copy (dst, _) -> check_write s.id dst
|
Ast.STMT_copy (dst, _) -> check_write s dst
|
||||||
| Ast.STMT_copy_binop (dst, _, _) -> check_write s.id dst
|
| Ast.STMT_copy_binop (dst, _, _) -> check_write s dst
|
||||||
| Ast.STMT_call (dst, _, _) -> check_write s.id dst
|
| Ast.STMT_call (dst, _, _) -> check_write s dst
|
||||||
| Ast.STMT_recv (dst, _) -> check_write s.id dst
|
| Ast.STMT_recv (dst, _) -> check_write s dst
|
||||||
| _ -> ()
|
| _ -> ()
|
||||||
end;
|
end;
|
||||||
inner.Walk.visit_stmt_pre s
|
inner.Walk.visit_stmt_pre s
|
||||||
|
@ -151,8 +157,7 @@ let function_effect_propagation_visitor
|
||||||
in
|
in
|
||||||
if lval_is_slot cx fn
|
if lval_is_slot cx fn
|
||||||
then
|
then
|
||||||
let t = lval_slot cx fn in
|
lower_to_callee_ty (lval_ty cx fn)
|
||||||
lower_to_callee_ty (slot_ty t)
|
|
||||||
else
|
else
|
||||||
begin
|
begin
|
||||||
let item = lval_item cx fn in
|
let item = lval_item cx fn in
|
||||||
|
|
|
@ -582,15 +582,13 @@ let atoms_slots (cx:ctxt) (az:Ast.atom array) : node_id array =
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let tup_inputs_slots (cx:ctxt) (az:Ast.tup_input array) : node_id array =
|
let tup_inputs_slots (cx:ctxt) (az:Ast.tup_input array) : node_id array =
|
||||||
Array.concat (List.map
|
Array.concat (List.map (atom_slots cx) (Array.to_list az))
|
||||||
(fun (_,_,a) -> atom_slots cx a)
|
|
||||||
(Array.to_list az))
|
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let rec_inputs_slots (cx:ctxt)
|
let rec_inputs_slots (cx:ctxt)
|
||||||
(inputs:Ast.rec_input array) : node_id array =
|
(inputs:Ast.rec_input array) : node_id array =
|
||||||
Array.concat (List.map
|
Array.concat (List.map
|
||||||
(fun (_, _, _, atom) -> atom_slots cx atom)
|
(fun (_, atom) -> atom_slots cx atom)
|
||||||
(Array.to_list inputs))
|
(Array.to_list inputs))
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
@ -606,14 +604,27 @@ let expr_slots (cx:ctxt) (e:Ast.expr) : node_id array =
|
||||||
(* Type extraction. *)
|
(* Type extraction. *)
|
||||||
|
|
||||||
let interior_slot_full mut ty : Ast.slot =
|
let interior_slot_full mut ty : Ast.slot =
|
||||||
{ Ast.slot_mode = Ast.MODE_interior;
|
let ty =
|
||||||
Ast.slot_mutable = mut;
|
if mut
|
||||||
Ast.slot_ty = Some ty }
|
then Ast.TY_mutable ty
|
||||||
|
else ty
|
||||||
|
in
|
||||||
|
{ Ast.slot_mode = Ast.MODE_interior;
|
||||||
|
Ast.slot_ty = Some ty }
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let exterior_slot_full mut ty : Ast.slot =
|
let exterior_slot_full mut ty : Ast.slot =
|
||||||
{ Ast.slot_mode = Ast.MODE_exterior;
|
let ty =
|
||||||
Ast.slot_mutable = mut;
|
match ty with
|
||||||
|
Ast.TY_exterior _ -> ty
|
||||||
|
| _ -> Ast.TY_exterior ty
|
||||||
|
in
|
||||||
|
let ty =
|
||||||
|
if mut
|
||||||
|
then Ast.TY_mutable ty
|
||||||
|
else ty
|
||||||
|
in
|
||||||
|
{ Ast.slot_mode = Ast.MODE_interior;
|
||||||
Ast.slot_ty = Some ty }
|
Ast.slot_ty = Some ty }
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
@ -626,12 +637,13 @@ let exterior_slot ty : Ast.slot = exterior_slot_full false ty
|
||||||
|
|
||||||
(* General folds of Ast.ty. *)
|
(* General folds of Ast.ty. *)
|
||||||
|
|
||||||
type ('ty, 'slot, 'slots, 'tag) ty_fold =
|
type ('ty, 'tys, 'slot, 'slots, 'tag) ty_fold =
|
||||||
{
|
{
|
||||||
(* Functions that correspond to interior nodes in Ast.ty. *)
|
(* Functions that correspond to interior nodes in Ast.ty. *)
|
||||||
ty_fold_slot : (Ast.mode * bool * 'ty) -> 'slot;
|
ty_fold_slot : (Ast.mode * 'ty) -> 'slot;
|
||||||
ty_fold_slots : ('slot array) -> 'slots;
|
ty_fold_slots : ('slot array) -> 'slots;
|
||||||
ty_fold_tags : (Ast.name, 'slots) Hashtbl.t -> 'tag;
|
ty_fold_tys : ('ty array) -> 'tys;
|
||||||
|
ty_fold_tags : (Ast.name, 'tys) Hashtbl.t -> 'tag;
|
||||||
|
|
||||||
(* Functions that correspond to the Ast.ty constructors. *)
|
(* Functions that correspond to the Ast.ty constructors. *)
|
||||||
ty_fold_any: unit -> 'ty;
|
ty_fold_any: unit -> 'ty;
|
||||||
|
@ -642,9 +654,9 @@ type ('ty, 'slot, 'slots, 'tag) ty_fold =
|
||||||
ty_fold_uint : unit -> 'ty;
|
ty_fold_uint : unit -> 'ty;
|
||||||
ty_fold_char : unit -> 'ty;
|
ty_fold_char : unit -> 'ty;
|
||||||
ty_fold_str : unit -> 'ty;
|
ty_fold_str : unit -> 'ty;
|
||||||
ty_fold_tup : 'slots -> 'ty;
|
ty_fold_tup : 'tys -> 'ty;
|
||||||
ty_fold_vec : 'slot -> 'ty;
|
ty_fold_vec : 'ty -> 'ty;
|
||||||
ty_fold_rec : (Ast.ident * 'slot) array -> 'ty;
|
ty_fold_rec : (Ast.ident * 'ty) array -> 'ty;
|
||||||
ty_fold_tag : 'tag -> 'ty;
|
ty_fold_tag : 'tag -> 'ty;
|
||||||
ty_fold_iso : (int * 'tag array) -> 'ty;
|
ty_fold_iso : (int * 'tag array) -> 'ty;
|
||||||
ty_fold_idx : int -> 'ty;
|
ty_fold_idx : int -> 'ty;
|
||||||
|
@ -659,21 +671,29 @@ type ('ty, 'slot, 'slots, 'tag) ty_fold =
|
||||||
ty_fold_param : (int * Ast.effect) -> 'ty;
|
ty_fold_param : (int * Ast.effect) -> 'ty;
|
||||||
ty_fold_named : Ast.name -> 'ty;
|
ty_fold_named : Ast.name -> 'ty;
|
||||||
ty_fold_type : unit -> 'ty;
|
ty_fold_type : unit -> 'ty;
|
||||||
|
ty_fold_exterior : 'ty -> 'ty;
|
||||||
|
ty_fold_mutable : 'ty -> 'ty;
|
||||||
ty_fold_constrained : ('ty * Ast.constrs) -> 'ty }
|
ty_fold_constrained : ('ty * Ast.constrs) -> 'ty }
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let rec fold_ty (f:('ty, 'slot, 'slots, 'tag) ty_fold) (ty:Ast.ty) : 'ty =
|
let rec fold_ty (f:('ty, 'tys, 'slot, 'slots, 'tag) ty_fold) (ty:Ast.ty) : 'ty =
|
||||||
let fold_slot (s:Ast.slot) : 'slot =
|
let fold_slot (s:Ast.slot) : 'slot =
|
||||||
f.ty_fold_slot (s.Ast.slot_mode,
|
f.ty_fold_slot (s.Ast.slot_mode,
|
||||||
s.Ast.slot_mutable,
|
|
||||||
fold_ty f (slot_ty s))
|
fold_ty f (slot_ty s))
|
||||||
in
|
in
|
||||||
|
|
||||||
let fold_slots (slots:Ast.slot array) : 'slots =
|
let fold_slots (slots:Ast.slot array) : 'slots =
|
||||||
f.ty_fold_slots (Array.map fold_slot slots)
|
f.ty_fold_slots (Array.map fold_slot slots)
|
||||||
in
|
in
|
||||||
let fold_tags (ttag:Ast.ty_tag) : 'tag =
|
|
||||||
f.ty_fold_tags (htab_map ttag (fun k v -> (k, fold_slots v)))
|
let fold_tys (tys:Ast.ty array) : 'tys =
|
||||||
|
f.ty_fold_tys (Array.map (fold_ty f) tys)
|
||||||
in
|
in
|
||||||
|
|
||||||
|
let fold_tags (ttag:Ast.ty_tag) : 'tag =
|
||||||
|
f.ty_fold_tags (htab_map ttag (fun k v -> (k, fold_tys v)))
|
||||||
|
in
|
||||||
|
|
||||||
let fold_sig tsig =
|
let fold_sig tsig =
|
||||||
(fold_slots tsig.Ast.sig_input_slots,
|
(fold_slots tsig.Ast.sig_input_slots,
|
||||||
tsig.Ast.sig_input_constrs,
|
tsig.Ast.sig_input_constrs,
|
||||||
|
@ -692,13 +712,15 @@ let rec fold_ty (f:('ty, 'slot, 'slots, 'tag) ty_fold) (ty:Ast.ty) : 'ty =
|
||||||
| Ast.TY_char -> f.ty_fold_char ()
|
| Ast.TY_char -> f.ty_fold_char ()
|
||||||
| Ast.TY_str -> f.ty_fold_str ()
|
| Ast.TY_str -> f.ty_fold_str ()
|
||||||
|
|
||||||
| Ast.TY_tup t -> f.ty_fold_tup (fold_slots t)
|
| Ast.TY_tup t -> f.ty_fold_tup (fold_tys t)
|
||||||
| Ast.TY_vec s -> f.ty_fold_vec (fold_slot s)
|
| Ast.TY_vec t -> f.ty_fold_vec (fold_ty f t)
|
||||||
| Ast.TY_rec r -> f.ty_fold_rec (Array.map (fun (k,v) -> (k,fold_slot v)) r)
|
| Ast.TY_rec r ->
|
||||||
|
f.ty_fold_rec (Array.map (fun (k,v) -> (k,fold_ty f v)) r)
|
||||||
|
|
||||||
| Ast.TY_tag tt -> f.ty_fold_tag (fold_tags tt)
|
| Ast.TY_tag tt -> f.ty_fold_tag (fold_tags tt)
|
||||||
| Ast.TY_iso ti -> f.ty_fold_iso (ti.Ast.iso_index,
|
| Ast.TY_iso ti ->
|
||||||
(Array.map fold_tags ti.Ast.iso_group))
|
f.ty_fold_iso (ti.Ast.iso_index,
|
||||||
|
(Array.map fold_tags ti.Ast.iso_group))
|
||||||
| Ast.TY_idx i -> f.ty_fold_idx i
|
| Ast.TY_idx i -> f.ty_fold_idx i
|
||||||
|
|
||||||
| Ast.TY_fn (tsig,taux) -> f.ty_fold_fn (fold_sig tsig, taux)
|
| Ast.TY_fn (tsig,taux) -> f.ty_fold_fn (fold_sig tsig, taux)
|
||||||
|
@ -713,16 +735,20 @@ let rec fold_ty (f:('ty, 'slot, 'slots, 'tag) ty_fold) (ty:Ast.ty) : 'ty =
|
||||||
| Ast.TY_named n -> f.ty_fold_named n
|
| Ast.TY_named n -> f.ty_fold_named n
|
||||||
| Ast.TY_type -> f.ty_fold_type ()
|
| Ast.TY_type -> f.ty_fold_type ()
|
||||||
|
|
||||||
|
| Ast.TY_exterior t -> f.ty_fold_exterior (fold_ty f t)
|
||||||
|
| Ast.TY_mutable t -> f.ty_fold_mutable (fold_ty f t)
|
||||||
|
|
||||||
| Ast.TY_constrained (t, constrs) ->
|
| Ast.TY_constrained (t, constrs) ->
|
||||||
f.ty_fold_constrained (fold_ty f t, constrs)
|
f.ty_fold_constrained (fold_ty f t, constrs)
|
||||||
|
|
||||||
;;
|
;;
|
||||||
|
|
||||||
type 'a simple_ty_fold = ('a, 'a, 'a, 'a) ty_fold
|
type 'a simple_ty_fold = ('a, 'a, 'a, 'a, 'a) ty_fold
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let ty_fold_default (default:'a) : 'a simple_ty_fold =
|
let ty_fold_default (default:'a) : 'a simple_ty_fold =
|
||||||
{ ty_fold_slot = (fun _ -> default);
|
{ ty_fold_tys = (fun _ -> default);
|
||||||
|
ty_fold_slot = (fun _ -> default);
|
||||||
ty_fold_slots = (fun _ -> default);
|
ty_fold_slots = (fun _ -> default);
|
||||||
ty_fold_tags = (fun _ -> default);
|
ty_fold_tags = (fun _ -> default);
|
||||||
ty_fold_any = (fun _ -> default);
|
ty_fold_any = (fun _ -> default);
|
||||||
|
@ -748,19 +774,22 @@ let ty_fold_default (default:'a) : 'a simple_ty_fold =
|
||||||
ty_fold_param = (fun _ -> default);
|
ty_fold_param = (fun _ -> default);
|
||||||
ty_fold_named = (fun _ -> default);
|
ty_fold_named = (fun _ -> default);
|
||||||
ty_fold_type = (fun _ -> default);
|
ty_fold_type = (fun _ -> default);
|
||||||
|
ty_fold_exterior = (fun _ -> default);
|
||||||
|
ty_fold_mutable = (fun _ -> default);
|
||||||
ty_fold_constrained = (fun _ -> default) }
|
ty_fold_constrained = (fun _ -> default) }
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let ty_fold_rebuild (id:Ast.ty -> Ast.ty)
|
let ty_fold_rebuild (id:Ast.ty -> Ast.ty)
|
||||||
: (Ast.ty, Ast.slot, Ast.slot array, Ast.ty_tag) ty_fold =
|
: (Ast.ty, Ast.ty array, Ast.slot, Ast.slot array, Ast.ty_tag) ty_fold =
|
||||||
let rebuild_fn ((islots, constrs, oslot), aux) =
|
let rebuild_fn ((islots, constrs, oslot), aux) =
|
||||||
({ Ast.sig_input_slots = islots;
|
({ Ast.sig_input_slots = islots;
|
||||||
Ast.sig_input_constrs = constrs;
|
Ast.sig_input_constrs = constrs;
|
||||||
Ast.sig_output_slot = oslot }, aux)
|
Ast.sig_output_slot = oslot }, aux)
|
||||||
in
|
in
|
||||||
{ ty_fold_slot = (fun (mode, mut, t) ->
|
{
|
||||||
|
ty_fold_tys = (fun ts -> ts);
|
||||||
|
ty_fold_slot = (fun (mode, t) ->
|
||||||
{ Ast.slot_mode = mode;
|
{ Ast.slot_mode = mode;
|
||||||
Ast.slot_mutable = mut;
|
|
||||||
Ast.slot_ty = Some t });
|
Ast.slot_ty = Some t });
|
||||||
ty_fold_slots = (fun slots -> slots);
|
ty_fold_slots = (fun slots -> slots);
|
||||||
ty_fold_tags = (fun htab -> htab);
|
ty_fold_tags = (fun htab -> htab);
|
||||||
|
@ -773,7 +802,7 @@ let ty_fold_rebuild (id:Ast.ty -> Ast.ty)
|
||||||
ty_fold_char = (fun _ -> id Ast.TY_char);
|
ty_fold_char = (fun _ -> id Ast.TY_char);
|
||||||
ty_fold_str = (fun _ -> id Ast.TY_str);
|
ty_fold_str = (fun _ -> id Ast.TY_str);
|
||||||
ty_fold_tup = (fun slots -> id (Ast.TY_tup slots));
|
ty_fold_tup = (fun slots -> id (Ast.TY_tup slots));
|
||||||
ty_fold_vec = (fun slot -> id (Ast.TY_vec slot));
|
ty_fold_vec = (fun t -> id (Ast.TY_vec t));
|
||||||
ty_fold_rec = (fun entries -> id (Ast.TY_rec entries));
|
ty_fold_rec = (fun entries -> id (Ast.TY_rec entries));
|
||||||
ty_fold_tag = (fun tag -> id (Ast.TY_tag tag));
|
ty_fold_tag = (fun tag -> id (Ast.TY_tag tag));
|
||||||
ty_fold_iso = (fun (i, tags) -> id (Ast.TY_iso { Ast.iso_index = i;
|
ty_fold_iso = (fun (i, tags) -> id (Ast.TY_iso { Ast.iso_index = i;
|
||||||
|
@ -791,6 +820,8 @@ let ty_fold_rebuild (id:Ast.ty -> Ast.ty)
|
||||||
ty_fold_param = (fun (i, mut) -> id (Ast.TY_param (i, mut)));
|
ty_fold_param = (fun (i, mut) -> id (Ast.TY_param (i, mut)));
|
||||||
ty_fold_named = (fun n -> id (Ast.TY_named n));
|
ty_fold_named = (fun n -> id (Ast.TY_named n));
|
||||||
ty_fold_type = (fun _ -> id (Ast.TY_type));
|
ty_fold_type = (fun _ -> id (Ast.TY_type));
|
||||||
|
ty_fold_exterior = (fun t -> id (Ast.TY_exterior t));
|
||||||
|
ty_fold_mutable = (fun t -> id (Ast.TY_mutable t));
|
||||||
ty_fold_constrained = (fun (t, constrs) ->
|
ty_fold_constrained = (fun (t, constrs) ->
|
||||||
id (Ast.TY_constrained (t, constrs))) }
|
id (Ast.TY_constrained (t, constrs))) }
|
||||||
;;
|
;;
|
||||||
|
@ -892,7 +923,7 @@ let associative_binary_op_ty_fold
|
||||||
in
|
in
|
||||||
{ base with
|
{ base with
|
||||||
ty_fold_slots = (fun slots -> reduce (Array.to_list slots));
|
ty_fold_slots = (fun slots -> reduce (Array.to_list slots));
|
||||||
ty_fold_slot = (fun (_, _, a) -> a);
|
ty_fold_slot = (fun (_, a) -> a);
|
||||||
ty_fold_tags = (fun tab -> reduce (htab_vals tab));
|
ty_fold_tags = (fun tab -> reduce (htab_vals tab));
|
||||||
ty_fold_tup = (fun a -> a);
|
ty_fold_tup = (fun a -> a);
|
||||||
ty_fold_vec = (fun a -> a);
|
ty_fold_vec = (fun a -> a);
|
||||||
|
@ -957,13 +988,9 @@ let lower_effect_of x y =
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let type_effect (t:Ast.ty) : Ast.effect =
|
let type_effect (t:Ast.ty) : Ast.effect =
|
||||||
let fold_slot ((*mode*)_, mut, eff) =
|
let fold_mutable _ = Ast.STATE in
|
||||||
if mut
|
|
||||||
then lower_effect_of Ast.STATE eff
|
|
||||||
else eff
|
|
||||||
in
|
|
||||||
let fold = associative_binary_op_ty_fold Ast.PURE lower_effect_of in
|
let fold = associative_binary_op_ty_fold Ast.PURE lower_effect_of in
|
||||||
let fold = { fold with ty_fold_slot = fold_slot } in
|
let fold = { fold with ty_fold_mutable = fold_mutable } in
|
||||||
fold_ty fold t
|
fold_ty fold t
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
@ -1037,15 +1064,15 @@ let check_concrete params thing =
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
|
||||||
let project_type_to_slot
|
let project_type
|
||||||
(base_ty:Ast.ty)
|
(base_ty:Ast.ty)
|
||||||
(comp:Ast.lval_component)
|
(comp:Ast.lval_component)
|
||||||
: Ast.slot =
|
: Ast.ty =
|
||||||
match (base_ty, comp) with
|
match (base_ty, comp) with
|
||||||
(Ast.TY_rec elts, Ast.COMP_named (Ast.COMP_ident id)) ->
|
(Ast.TY_rec elts, Ast.COMP_named (Ast.COMP_ident id)) ->
|
||||||
begin
|
begin
|
||||||
match atab_search elts id with
|
match atab_search elts id with
|
||||||
Some slot -> slot
|
Some ty -> ty
|
||||||
| None -> err None "unknown record-member '%s'" id
|
| None -> err None "unknown record-member '%s'" id
|
||||||
end
|
end
|
||||||
|
|
||||||
|
@ -1054,14 +1081,10 @@ let project_type_to_slot
|
||||||
then elts.(i)
|
then elts.(i)
|
||||||
else err None "out-of-range tuple index %d" i
|
else err None "out-of-range tuple index %d" i
|
||||||
|
|
||||||
| (Ast.TY_vec slot, Ast.COMP_atom _) ->
|
| (Ast.TY_vec ty, Ast.COMP_atom _) -> ty
|
||||||
slot
|
| (Ast.TY_str, Ast.COMP_atom _) -> (Ast.TY_mach TY_u8)
|
||||||
|
|
||||||
| (Ast.TY_str, Ast.COMP_atom _) ->
|
|
||||||
interior_slot (Ast.TY_mach TY_u8)
|
|
||||||
|
|
||||||
| (Ast.TY_obj (_, fns), Ast.COMP_named (Ast.COMP_ident id)) ->
|
| (Ast.TY_obj (_, fns), Ast.COMP_named (Ast.COMP_ident id)) ->
|
||||||
interior_slot (Ast.TY_fn (Hashtbl.find fns id))
|
(Ast.TY_fn (Hashtbl.find fns id))
|
||||||
|
|
||||||
| (_,_) ->
|
| (_,_) ->
|
||||||
bug ()
|
bug ()
|
||||||
|
@ -1070,16 +1093,6 @@ let project_type_to_slot
|
||||||
Ast.sprintf_ty base_ty Ast.sprintf_lval_component comp
|
Ast.sprintf_ty base_ty Ast.sprintf_lval_component comp
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
|
||||||
(* NB: this will fail if lval is not a slot. *)
|
|
||||||
let rec lval_slot (cx:ctxt) (lval:Ast.lval) : Ast.slot =
|
|
||||||
match lval with
|
|
||||||
Ast.LVAL_base nb -> lval_to_slot cx nb.id
|
|
||||||
| Ast.LVAL_ext (base, comp) ->
|
|
||||||
let base_ty = slot_ty (lval_slot cx base) in
|
|
||||||
project_type_to_slot base_ty comp
|
|
||||||
;;
|
|
||||||
|
|
||||||
let exports_permit (view:Ast.mod_view) (ident:Ast.ident) : bool =
|
let exports_permit (view:Ast.mod_view) (ident:Ast.ident) : bool =
|
||||||
(Hashtbl.mem view.Ast.view_exports Ast.EXPORT_all_decls) ||
|
(Hashtbl.mem view.Ast.view_exports Ast.EXPORT_all_decls) ||
|
||||||
(Hashtbl.mem view.Ast.view_exports (Ast.EXPORT_ident ident))
|
(Hashtbl.mem view.Ast.view_exports (Ast.EXPORT_ident ident))
|
||||||
|
@ -1150,6 +1163,10 @@ let lval_is_direct_mod (cx:ctxt) (lval:Ast.lval) : bool =
|
||||||
| _ -> false
|
| _ -> false
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
let lval_ty (cx:ctxt) (lval:Ast.lval) : Ast.ty =
|
||||||
|
Hashtbl.find cx.ctxt_all_lval_types (lval_base_id lval)
|
||||||
|
;;
|
||||||
|
|
||||||
let lval_is_static (cx:ctxt) (lval:Ast.lval) : bool =
|
let lval_is_static (cx:ctxt) (lval:Ast.lval) : bool =
|
||||||
defn_is_static (resolve_lval cx lval)
|
defn_is_static (resolve_lval cx lval)
|
||||||
;;
|
;;
|
||||||
|
@ -1164,7 +1181,7 @@ let lval_is_obj_vtbl (cx:ctxt) (lval:Ast.lval) : bool =
|
||||||
match lval with
|
match lval with
|
||||||
Ast.LVAL_ext (base, _) ->
|
Ast.LVAL_ext (base, _) ->
|
||||||
begin
|
begin
|
||||||
match slot_ty (lval_slot cx base) with
|
match lval_ty cx base with
|
||||||
Ast.TY_obj _ -> true
|
Ast.TY_obj _ -> true
|
||||||
| _ -> false
|
| _ -> false
|
||||||
end
|
end
|
||||||
|
@ -1172,11 +1189,6 @@ let lval_is_obj_vtbl (cx:ctxt) (lval:Ast.lval) : bool =
|
||||||
else false
|
else false
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let rec lval_ty (cx:ctxt) (lval:Ast.lval) : Ast.ty =
|
|
||||||
let base_id = lval_base_id lval in
|
|
||||||
Hashtbl.find cx.ctxt_all_lval_types base_id
|
|
||||||
;;
|
|
||||||
|
|
||||||
let rec atom_type (cx:ctxt) (at:Ast.atom) : Ast.ty =
|
let rec atom_type (cx:ctxt) (at:Ast.atom) : Ast.ty =
|
||||||
match at with
|
match at with
|
||||||
Ast.ATOM_literal {node=(Ast.LIT_int _); id=_} -> Ast.TY_int
|
Ast.ATOM_literal {node=(Ast.LIT_int _); id=_} -> Ast.TY_int
|
||||||
|
@ -1741,7 +1753,7 @@ let rec referent_type (abi:Abi.abi) (t:Ast.ty) : Il.referent_ty =
|
||||||
let ptr = sp Il.OpaqueTy in
|
let ptr = sp Il.OpaqueTy in
|
||||||
let rc_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
|
let rc_ptr = sp (Il.StructTy [| word; Il.OpaqueTy |]) in
|
||||||
let codeptr = sp Il.CodeTy in
|
let codeptr = sp Il.CodeTy in
|
||||||
let tup ttup = Il.StructTy (Array.map (slot_referent_type abi) ttup) in
|
let tup ttup = Il.StructTy (Array.map (referent_type abi) ttup) in
|
||||||
let tag ttag =
|
let tag ttag =
|
||||||
let union =
|
let union =
|
||||||
Il.UnionTy
|
Il.UnionTy
|
||||||
|
@ -1802,6 +1814,11 @@ let rec referent_type (abi:Abi.abi) (t:Ast.ty) : Il.referent_ty =
|
||||||
|
|
||||||
| Ast.TY_native _ -> ptr
|
| Ast.TY_native _ -> ptr
|
||||||
|
|
||||||
|
| Ast.TY_exterior t ->
|
||||||
|
sp (Il.StructTy [| word; referent_type abi t |])
|
||||||
|
|
||||||
|
| Ast.TY_mutable t -> referent_type abi t
|
||||||
|
|
||||||
| Ast.TY_param (i, _) -> Il.ParamTy i
|
| Ast.TY_param (i, _) -> Il.ParamTy i
|
||||||
|
|
||||||
| Ast.TY_named _ -> bug () "named type in referent_type"
|
| Ast.TY_named _ -> bug () "named type in referent_type"
|
||||||
|
@ -1809,16 +1826,11 @@ let rec referent_type (abi:Abi.abi) (t:Ast.ty) : Il.referent_ty =
|
||||||
|
|
||||||
and slot_referent_type (abi:Abi.abi) (sl:Ast.slot) : Il.referent_ty =
|
and slot_referent_type (abi:Abi.abi) (sl:Ast.slot) : Il.referent_ty =
|
||||||
let s t = Il.ScalarTy t in
|
let s t = Il.ScalarTy t in
|
||||||
let v b = Il.ValTy b in
|
|
||||||
let p t = Il.AddrTy t in
|
let p t = Il.AddrTy t in
|
||||||
let sv b = s (v b) in
|
|
||||||
let sp t = s (p t) in
|
let sp t = s (p t) in
|
||||||
|
|
||||||
let word = sv abi.Abi.abi_word_bits in
|
|
||||||
|
|
||||||
let rty = referent_type abi (slot_ty sl) in
|
let rty = referent_type abi (slot_ty sl) in
|
||||||
match sl.Ast.slot_mode with
|
match sl.Ast.slot_mode with
|
||||||
Ast.MODE_exterior _ -> sp (Il.StructTy [| word; rty |])
|
|
||||||
| Ast.MODE_interior _ -> rty
|
| Ast.MODE_interior _ -> rty
|
||||||
| Ast.MODE_alias _ -> sp rty
|
| Ast.MODE_alias _ -> sp rty
|
||||||
;;
|
;;
|
||||||
|
@ -1940,14 +1952,17 @@ let word_slot (abi:Abi.abi) : Ast.slot =
|
||||||
|
|
||||||
let alias_slot (ty:Ast.ty) : Ast.slot =
|
let alias_slot (ty:Ast.ty) : Ast.slot =
|
||||||
{ Ast.slot_mode = Ast.MODE_alias;
|
{ Ast.slot_mode = Ast.MODE_alias;
|
||||||
Ast.slot_mutable = false;
|
|
||||||
Ast.slot_ty = Some ty }
|
Ast.slot_ty = Some ty }
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let mutable_alias_slot (ty:Ast.ty) : Ast.slot =
|
let mutable_alias_slot (ty:Ast.ty) : Ast.slot =
|
||||||
{ Ast.slot_mode = Ast.MODE_alias;
|
let ty =
|
||||||
Ast.slot_mutable = true;
|
match ty with
|
||||||
Ast.slot_ty = Some ty }
|
Ast.TY_mutable _ -> ty
|
||||||
|
| _ -> Ast.TY_mutable ty
|
||||||
|
in
|
||||||
|
{ Ast.slot_mode = Ast.MODE_alias;
|
||||||
|
Ast.slot_ty = Some ty }
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let mk_ty_fn_or_iter
|
let mk_ty_fn_or_iter
|
||||||
|
@ -2002,12 +2017,10 @@ let item_str (cx:ctxt) (id:node_id) : string =
|
||||||
|
|
||||||
let ty_str (ty:Ast.ty) : string =
|
let ty_str (ty:Ast.ty) : string =
|
||||||
let base = associative_binary_op_ty_fold "" (fun a b -> a ^ b) in
|
let base = associative_binary_op_ty_fold "" (fun a b -> a ^ b) in
|
||||||
let fold_slot (mode,mut,ty) =
|
let fold_slot (mode,ty) =
|
||||||
(if mut then "m" else "")
|
(match mode with
|
||||||
^ (match mode with
|
Ast.MODE_alias -> "a"
|
||||||
Ast.MODE_exterior -> "e"
|
| Ast.MODE_interior -> "")
|
||||||
| Ast.MODE_alias -> "a"
|
|
||||||
| Ast.MODE_interior -> "")
|
|
||||||
^ ty
|
^ ty
|
||||||
in
|
in
|
||||||
let num n = (string_of_int n) ^ "$" in
|
let num n = (string_of_int n) ^ "$" in
|
||||||
|
@ -2080,6 +2093,8 @@ let ty_str (ty:Ast.ty) : string =
|
||||||
ty_fold_native = (fun _ -> "N");
|
ty_fold_native = (fun _ -> "N");
|
||||||
ty_fold_param = (fun _ -> "P");
|
ty_fold_param = (fun _ -> "P");
|
||||||
ty_fold_type = (fun _ -> "Y");
|
ty_fold_type = (fun _ -> "Y");
|
||||||
|
ty_fold_mutable = (fun t -> "m" ^ t);
|
||||||
|
ty_fold_exterior = (fun t -> "e" ^ t);
|
||||||
|
|
||||||
(* FIXME (issue #78): encode obj types. *)
|
(* FIXME (issue #78): encode obj types. *)
|
||||||
(* FIXME (issue #78): encode opaque and param numbers. *)
|
(* FIXME (issue #78): encode opaque and param numbers. *)
|
||||||
|
|
1058
src/boot/me/trans.ml
1058
src/boot/me/trans.ml
File diff suppressed because it is too large
Load Diff
|
@ -112,29 +112,35 @@ let word_ty_signed_mach (abi:Abi.abi) : ty_mach =
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
|
||||||
let slot_mem_ctrl (slot:Ast.slot) : mem_ctrl =
|
let rec ty_mem_ctrl (ty:Ast.ty) : mem_ctrl =
|
||||||
let ty = slot_ty slot in
|
match ty with
|
||||||
match ty with
|
Ast.TY_port _
|
||||||
Ast.TY_port _
|
| Ast.TY_chan _
|
||||||
| Ast.TY_chan _
|
| Ast.TY_task
|
||||||
| Ast.TY_task
|
| Ast.TY_str -> MEM_rc_opaque
|
||||||
| Ast.TY_str -> MEM_rc_opaque
|
| Ast.TY_vec _ ->
|
||||||
| Ast.TY_vec _ ->
|
if type_has_state ty
|
||||||
if type_has_state ty
|
then MEM_gc
|
||||||
then MEM_gc
|
else MEM_rc_opaque
|
||||||
|
| Ast.TY_exterior t ->
|
||||||
|
if type_has_state t
|
||||||
|
then MEM_gc
|
||||||
|
else
|
||||||
|
if type_is_structured t
|
||||||
|
then MEM_rc_struct
|
||||||
else MEM_rc_opaque
|
else MEM_rc_opaque
|
||||||
| _ ->
|
| Ast.TY_mutable t
|
||||||
match slot.Ast.slot_mode with
|
| Ast.TY_constrained (t, _) ->
|
||||||
Ast.MODE_exterior _ when type_is_structured ty ->
|
ty_mem_ctrl t
|
||||||
if type_has_state ty
|
| _ ->
|
||||||
then MEM_gc
|
MEM_interior
|
||||||
else MEM_rc_struct
|
;;
|
||||||
| Ast.MODE_exterior _ ->
|
|
||||||
if type_has_state ty
|
let slot_mem_ctrl (slot:Ast.slot) : mem_ctrl =
|
||||||
then MEM_gc
|
match slot.Ast.slot_mode with
|
||||||
else MEM_rc_opaque
|
Ast.MODE_alias -> MEM_interior
|
||||||
| _ ->
|
| Ast.MODE_interior ->
|
||||||
MEM_interior
|
ty_mem_ctrl (slot_ty slot)
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
|
||||||
|
@ -200,33 +206,33 @@ let next_power_of_two (x:int64) : int64 =
|
||||||
Int64.add 1L (!xr)
|
Int64.add 1L (!xr)
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let iter_tup_slots
|
let iter_tup_parts
|
||||||
(get_element_ptr:'a -> int -> 'a)
|
(get_element_ptr:'a -> int -> 'a)
|
||||||
(dst_ptr:'a)
|
(dst_ptr:'a)
|
||||||
(src_ptr:'a)
|
(src_ptr:'a)
|
||||||
(slots:Ast.ty_tup)
|
(slots:Ast.ty_tup)
|
||||||
(f:'a -> 'a -> Ast.slot -> (Ast.ty_iso option) -> unit)
|
(f:'a -> 'a -> Ast.ty -> (Ast.ty_iso option) -> unit)
|
||||||
(curr_iso:Ast.ty_iso option)
|
(curr_iso:Ast.ty_iso option)
|
||||||
: unit =
|
: unit =
|
||||||
Array.iteri
|
Array.iteri
|
||||||
begin
|
begin
|
||||||
fun i slot ->
|
fun i ty ->
|
||||||
f (get_element_ptr dst_ptr i)
|
f (get_element_ptr dst_ptr i)
|
||||||
(get_element_ptr src_ptr i)
|
(get_element_ptr src_ptr i)
|
||||||
slot curr_iso
|
ty curr_iso
|
||||||
end
|
end
|
||||||
slots
|
slots
|
||||||
;;
|
;;
|
||||||
|
|
||||||
let iter_rec_slots
|
let iter_rec_parts
|
||||||
(get_element_ptr:'a -> int -> 'a)
|
(get_element_ptr:'a -> int -> 'a)
|
||||||
(dst_ptr:'a)
|
(dst_ptr:'a)
|
||||||
(src_ptr:'a)
|
(src_ptr:'a)
|
||||||
(entries:Ast.ty_rec)
|
(entries:Ast.ty_rec)
|
||||||
(f:'a -> 'a -> Ast.slot -> (Ast.ty_iso option) -> unit)
|
(f:'a -> 'a -> Ast.ty -> (Ast.ty_iso option) -> unit)
|
||||||
(curr_iso:Ast.ty_iso option)
|
(curr_iso:Ast.ty_iso option)
|
||||||
: unit =
|
: unit =
|
||||||
iter_tup_slots get_element_ptr dst_ptr src_ptr
|
iter_tup_parts get_element_ptr dst_ptr src_ptr
|
||||||
(Array.map snd entries) f curr_iso
|
(Array.map snd entries) f curr_iso
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
|
|
@ -33,6 +33,23 @@ type binopsig =
|
||||||
| BINOPSIG_plus_plus_plus (* plusable a * plusable a -> plusable a *)
|
| BINOPSIG_plus_plus_plus (* plusable a * plusable a -> plusable a *)
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
|
||||||
|
(* In some instances we will strip off a layer of mutability or exterior-ness,
|
||||||
|
* as trans is willing to transplant and/or overlook mutability / exterior
|
||||||
|
* differences wrt. many operators.
|
||||||
|
*
|
||||||
|
* Note: there is a secondary mutability-checking pass in effect.ml to ensure
|
||||||
|
* you're not actually mutating the insides of an immutable. That's not the
|
||||||
|
* typechecker's job.
|
||||||
|
*)
|
||||||
|
let simplified t =
|
||||||
|
match t with
|
||||||
|
Ast.TY_mutable (Ast.TY_exterior t) -> t
|
||||||
|
| Ast.TY_mutable t -> t
|
||||||
|
| Ast.TY_exterior t -> t
|
||||||
|
| _ -> t
|
||||||
|
;;
|
||||||
|
|
||||||
let rec tyspec_to_str (ts:tyspec) : string =
|
let rec tyspec_to_str (ts:tyspec) : string =
|
||||||
|
|
||||||
let fmt = Format.fprintf in
|
let fmt = Format.fprintf in
|
||||||
|
@ -253,17 +270,14 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
(dct:dict)
|
(dct:dict)
|
||||||
(fields:Ast.ty_rec)
|
(fields:Ast.ty_rec)
|
||||||
: unit =
|
: unit =
|
||||||
let rec find_slot (query:Ast.ident) i : Ast.slot =
|
let find_ty (query:Ast.ident) : Ast.ty =
|
||||||
if i = Array.length fields
|
match atab_search fields query with
|
||||||
then fail ()
|
None -> fail()
|
||||||
else match fields.(i) with
|
| Some t -> t
|
||||||
(ident, slot) ->
|
|
||||||
if ident = query then slot
|
|
||||||
else find_slot query (i + 1)
|
|
||||||
in
|
in
|
||||||
|
|
||||||
let check_entry ident tv =
|
let check_entry ident tv =
|
||||||
unify_slot (find_slot ident 0) None tv
|
unify_ty (find_ty ident) tv
|
||||||
in
|
in
|
||||||
Hashtbl.iter check_entry dct
|
Hashtbl.iter check_entry dct
|
||||||
in
|
in
|
||||||
|
@ -290,18 +304,20 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
| Ast.TY_fn _ | Ast.TY_obj _
|
| Ast.TY_fn _ | Ast.TY_obj _
|
||||||
| Ast.TY_param _ | Ast.TY_native _ | Ast.TY_type -> false
|
| Ast.TY_param _ | Ast.TY_native _ | Ast.TY_type -> false
|
||||||
| Ast.TY_named _ -> bug () "unexpected named type"
|
| Ast.TY_named _ -> bug () "unexpected named type"
|
||||||
|
| Ast.TY_exterior ty
|
||||||
|
| Ast.TY_mutable ty
|
||||||
| Ast.TY_constrained (ty, _) ->
|
| Ast.TY_constrained (ty, _) ->
|
||||||
is_comparable_or_ordered comparable ty
|
is_comparable_or_ordered comparable ty
|
||||||
in
|
in
|
||||||
|
|
||||||
let floating (ty:Ast.ty) : bool =
|
let floating (ty:Ast.ty) : bool =
|
||||||
match ty with
|
match simplified ty with
|
||||||
Ast.TY_mach TY_f32 | Ast.TY_mach TY_f64 -> true
|
Ast.TY_mach TY_f32 | Ast.TY_mach TY_f64 -> true
|
||||||
| _ -> false
|
| _ -> false
|
||||||
in
|
in
|
||||||
|
|
||||||
let integral (ty:Ast.ty) : bool =
|
let integral (ty:Ast.ty) : bool =
|
||||||
match ty with
|
match simplified ty with
|
||||||
Ast.TY_int | Ast.TY_uint | Ast.TY_mach TY_u8 | Ast.TY_mach TY_u16
|
Ast.TY_int | Ast.TY_uint | Ast.TY_mach TY_u8 | Ast.TY_mach TY_u16
|
||||||
| Ast.TY_mach TY_u32 | Ast.TY_mach TY_u64 | Ast.TY_mach TY_i8
|
| Ast.TY_mach TY_u32 | Ast.TY_mach TY_u64 | Ast.TY_mach TY_i8
|
||||||
| Ast.TY_mach TY_i16 | Ast.TY_mach TY_i32
|
| Ast.TY_mach TY_i16 | Ast.TY_mach TY_i32
|
||||||
|
@ -313,7 +329,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
let numeric (ty:Ast.ty) : bool = (integral ty) || (floating ty) in
|
let numeric (ty:Ast.ty) : bool = (integral ty) || (floating ty) in
|
||||||
|
|
||||||
let plusable (ty:Ast.ty) : bool =
|
let plusable (ty:Ast.ty) : bool =
|
||||||
match ty with
|
match simplified ty with
|
||||||
Ast.TY_str -> true
|
Ast.TY_str -> true
|
||||||
| Ast.TY_vec _ -> true
|
| Ast.TY_vec _ -> true
|
||||||
| _ -> numeric ty
|
| _ -> numeric ty
|
||||||
|
@ -369,7 +385,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
| (TYSPEC_collection tv, TYSPEC_resolved (params, ty)) ->
|
| (TYSPEC_collection tv, TYSPEC_resolved (params, ty)) ->
|
||||||
begin
|
begin
|
||||||
match ty with
|
match ty with
|
||||||
Ast.TY_vec slot -> unify_slot slot None tv
|
Ast.TY_vec ty -> unify_ty ty tv
|
||||||
| Ast.TY_str -> unify_ty (Ast.TY_mach TY_u8) tv
|
| Ast.TY_str -> unify_ty (Ast.TY_mach TY_u8) tv
|
||||||
| _ -> fail ()
|
| _ -> fail ()
|
||||||
end;
|
end;
|
||||||
|
@ -439,12 +455,12 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
| (TYSPEC_tuple tvs, TYSPEC_resolved (params, ty)) ->
|
| (TYSPEC_tuple tvs, TYSPEC_resolved (params, ty)) ->
|
||||||
begin
|
begin
|
||||||
match ty with
|
match ty with
|
||||||
Ast.TY_tup (elem_slots:Ast.slot array) ->
|
Ast.TY_tup (elem_tys:Ast.ty array) ->
|
||||||
if (Array.length elem_slots) < (Array.length tvs)
|
if (Array.length elem_tys) <> (Array.length tvs)
|
||||||
then fail ()
|
then fail ()
|
||||||
else
|
else
|
||||||
let check_elem i tv =
|
let check_elem i tv =
|
||||||
unify_slot (elem_slots.(i)) None tv
|
unify_ty (elem_tys.(i)) tv
|
||||||
in
|
in
|
||||||
Array.iteri check_elem tvs
|
Array.iteri check_elem tvs
|
||||||
| _ -> fail ()
|
| _ -> fail ()
|
||||||
|
@ -455,9 +471,9 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
| (TYSPEC_vector tv, TYSPEC_resolved (params, ty)) ->
|
| (TYSPEC_vector tv, TYSPEC_resolved (params, ty)) ->
|
||||||
begin
|
begin
|
||||||
match ty with
|
match ty with
|
||||||
Ast.TY_vec slot ->
|
Ast.TY_vec ty ->
|
||||||
unify_slot slot None tv;
|
unify_ty ty tv;
|
||||||
TYSPEC_resolved (params, ty)
|
TYSPEC_resolved (params, Ast.TY_vec ty)
|
||||||
| _ -> fail ()
|
| _ -> fail ()
|
||||||
end
|
end
|
||||||
|
|
||||||
|
@ -942,7 +958,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
unify_lval' base base_tv;
|
unify_lval' base base_tv;
|
||||||
match !(resolve_tyvar base_tv) with
|
match !(resolve_tyvar base_tv) with
|
||||||
TYSPEC_resolved (_, ty) ->
|
TYSPEC_resolved (_, ty) ->
|
||||||
unify_ty (slot_ty (project_type_to_slot ty comp)) tv
|
unify_ty (project_type ty comp) tv
|
||||||
| _ ->
|
| _ ->
|
||||||
()
|
()
|
||||||
|
|
||||||
|
@ -981,7 +997,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
| Ast.STMT_init_rec (lval, fields, Some base) ->
|
| Ast.STMT_init_rec (lval, fields, Some base) ->
|
||||||
let dct = Hashtbl.create 10 in
|
let dct = Hashtbl.create 10 in
|
||||||
let tvrec = ref (TYSPEC_record dct) in
|
let tvrec = ref (TYSPEC_record dct) in
|
||||||
let add_field (ident, _, _, atom) =
|
let add_field (ident, atom) =
|
||||||
let tv = ref TYSPEC_all in
|
let tv = ref TYSPEC_all in
|
||||||
unify_atom atom tv;
|
unify_atom atom tv;
|
||||||
Hashtbl.add dct ident tv
|
Hashtbl.add dct ident tv
|
||||||
|
@ -994,7 +1010,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
|
|
||||||
| Ast.STMT_init_rec (lval, fields, None) ->
|
| Ast.STMT_init_rec (lval, fields, None) ->
|
||||||
let dct = Hashtbl.create 10 in
|
let dct = Hashtbl.create 10 in
|
||||||
let add_field (ident, _, _, atom) =
|
let add_field (ident, atom) =
|
||||||
let tv = ref TYSPEC_all in
|
let tv = ref TYSPEC_all in
|
||||||
unify_atom atom tv;
|
unify_atom atom tv;
|
||||||
Hashtbl.add dct ident tv
|
Hashtbl.add dct ident tv
|
||||||
|
@ -1003,7 +1019,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
unify_lval lval (ref (TYSPEC_record dct))
|
unify_lval lval (ref (TYSPEC_record dct))
|
||||||
|
|
||||||
| Ast.STMT_init_tup (lval, members) ->
|
| Ast.STMT_init_tup (lval, members) ->
|
||||||
let member_to_tv (_, _, atom) =
|
let member_to_tv atom =
|
||||||
let tv = ref TYSPEC_all in
|
let tv = ref TYSPEC_all in
|
||||||
unify_atom atom tv;
|
unify_atom atom tv;
|
||||||
tv
|
tv
|
||||||
|
@ -1011,7 +1027,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
let member_tvs = Array.map member_to_tv members in
|
let member_tvs = Array.map member_to_tv members in
|
||||||
unify_lval lval (ref (TYSPEC_tuple member_tvs))
|
unify_lval lval (ref (TYSPEC_tuple member_tvs))
|
||||||
|
|
||||||
| Ast.STMT_init_vec (lval, _, atoms) ->
|
| Ast.STMT_init_vec (lval, atoms) ->
|
||||||
let tv = ref TYSPEC_all in
|
let tv = ref TYSPEC_all in
|
||||||
let unify_with_tv atom = unify_atom atom tv in
|
let unify_with_tv atom = unify_atom atom tv in
|
||||||
Array.iter unify_with_tv atoms;
|
Array.iter unify_with_tv atoms;
|
||||||
|
@ -1181,8 +1197,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
Ast.TY_fn (tsig, _) ->
|
Ast.TY_fn (tsig, _) ->
|
||||||
begin
|
begin
|
||||||
let vec_str =
|
let vec_str =
|
||||||
interior_slot (Ast.TY_vec
|
interior_slot (Ast.TY_vec Ast.TY_str)
|
||||||
(interior_slot Ast.TY_str))
|
|
||||||
in
|
in
|
||||||
match tsig.Ast.sig_input_slots with
|
match tsig.Ast.sig_input_slots with
|
||||||
[| |] -> ()
|
[| |] -> ()
|
||||||
|
@ -1236,13 +1251,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
let tag_tv = ref TYSPEC_all in
|
let tag_tv = ref TYSPEC_all in
|
||||||
unify_ty tag_ty tag_tv;
|
unify_ty tag_ty tag_tv;
|
||||||
unify_tyvars expected tag_tv;
|
unify_tyvars expected tag_tv;
|
||||||
List.iter
|
List.iter expect
|
||||||
begin
|
|
||||||
fun slot ->
|
|
||||||
match slot.Ast.slot_ty with
|
|
||||||
Some ty -> expect ty
|
|
||||||
| None -> bug () "no slot type in tag slot tuple"
|
|
||||||
end
|
|
||||||
(List.rev (Array.to_list tag_ty_tup));
|
(List.rev (Array.to_list tag_ty_tup));
|
||||||
|
|
||||||
| Ast.PAT_slot (sloti, _) ->
|
| Ast.PAT_slot (sloti, _) ->
|
||||||
|
@ -1336,8 +1345,14 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
let defn = Hashtbl.find cx.ctxt_all_defns id in
|
let defn = Hashtbl.find cx.ctxt_all_defns id in
|
||||||
match defn with
|
match defn with
|
||||||
DEFN_slot slot_defn ->
|
DEFN_slot slot_defn ->
|
||||||
Hashtbl.replace cx.ctxt_all_defns id
|
begin
|
||||||
(DEFN_slot { slot_defn with Ast.slot_ty = Some ty })
|
match slot_defn.Ast.slot_ty with
|
||||||
|
Some _ -> ()
|
||||||
|
| None ->
|
||||||
|
Hashtbl.replace cx.ctxt_all_defns id
|
||||||
|
(DEFN_slot { slot_defn with
|
||||||
|
Ast.slot_ty = Some ty })
|
||||||
|
end
|
||||||
| _ -> bug () "check_auto_tyvar: no slot defn"
|
| _ -> bug () "check_auto_tyvar: no slot defn"
|
||||||
in
|
in
|
||||||
|
|
||||||
|
@ -1349,7 +1364,7 @@ let process_crate (cx:ctxt) (crate:Ast.crate) : unit =
|
||||||
begin
|
begin
|
||||||
match !(resolve_tyvar tv) with
|
match !(resolve_tyvar tv) with
|
||||||
TYSPEC_resolved ([||], ty) ->
|
TYSPEC_resolved ([||], ty) ->
|
||||||
(Ast.TY_vec (interior_slot ty))
|
(Ast.TY_vec ty)
|
||||||
| _ ->
|
| _ ->
|
||||||
err (Some id)
|
err (Some id)
|
||||||
"unresolved vector-element type in %s (%d)"
|
"unresolved vector-element type in %s (%d)"
|
||||||
|
|
|
@ -419,7 +419,7 @@ let condition_assigning_visitor
|
||||||
raise_precondition s.id precond;
|
raise_precondition s.id precond;
|
||||||
raise_postcondition s.id postcond
|
raise_postcondition s.id postcond
|
||||||
|
|
||||||
| Ast.STMT_init_vec (dst, _, atoms) ->
|
| Ast.STMT_init_vec (dst, atoms) ->
|
||||||
let precond = slot_inits (atoms_slots cx atoms) in
|
let precond = slot_inits (atoms_slots cx atoms) in
|
||||||
let postcond = slot_inits (lval_slots cx dst) in
|
let postcond = slot_inits (lval_slots cx dst) in
|
||||||
raise_precondition s.id precond;
|
raise_precondition s.id precond;
|
||||||
|
@ -980,13 +980,19 @@ let lifecycle_visitor
|
||||||
if initializing
|
if initializing
|
||||||
then
|
then
|
||||||
begin
|
begin
|
||||||
Hashtbl.add cx.ctxt_copy_stmt_is_init s.id ();
|
iflog cx
|
||||||
|
begin
|
||||||
|
fun _ ->
|
||||||
|
log cx "noting lval %a init at stmt %a"
|
||||||
|
Ast.sprintf_lval lv_dst Ast.sprintf_stmt s
|
||||||
|
end;
|
||||||
|
Hashtbl.replace cx.ctxt_copy_stmt_is_init s.id ();
|
||||||
init_lval lv_dst
|
init_lval lv_dst
|
||||||
end;
|
end;
|
||||||
|
|
||||||
| Ast.STMT_init_rec (lv_dst, _, _)
|
| Ast.STMT_init_rec (lv_dst, _, _)
|
||||||
| Ast.STMT_init_tup (lv_dst, _)
|
| Ast.STMT_init_tup (lv_dst, _)
|
||||||
| Ast.STMT_init_vec (lv_dst, _, _)
|
| Ast.STMT_init_vec (lv_dst, _)
|
||||||
| Ast.STMT_init_str (lv_dst, _)
|
| Ast.STMT_init_str (lv_dst, _)
|
||||||
| Ast.STMT_init_port lv_dst
|
| Ast.STMT_init_port lv_dst
|
||||||
| Ast.STMT_init_chan (lv_dst, _) ->
|
| Ast.STMT_init_chan (lv_dst, _) ->
|
||||||
|
|
|
@ -262,7 +262,7 @@ and walk_mod_item
|
||||||
item
|
item
|
||||||
|
|
||||||
|
|
||||||
and walk_ty_tup v ttup = Array.iter (walk_slot v) ttup
|
and walk_ty_tup v ttup = Array.iter (walk_ty v) ttup
|
||||||
|
|
||||||
and walk_ty_tag v ttag = Hashtbl.iter (fun _ t -> walk_ty_tup v t) ttag
|
and walk_ty_tag v ttag = Hashtbl.iter (fun _ t -> walk_ty_tup v t) ttag
|
||||||
|
|
||||||
|
@ -273,8 +273,8 @@ and walk_ty
|
||||||
let children _ =
|
let children _ =
|
||||||
match ty with
|
match ty with
|
||||||
Ast.TY_tup ttup -> walk_ty_tup v ttup
|
Ast.TY_tup ttup -> walk_ty_tup v ttup
|
||||||
| Ast.TY_vec s -> walk_slot v s
|
| Ast.TY_vec s -> walk_ty v s
|
||||||
| Ast.TY_rec trec -> Array.iter (fun (_, s) -> walk_slot v s) trec
|
| Ast.TY_rec trec -> Array.iter (fun (_, s) -> walk_ty v s) trec
|
||||||
| Ast.TY_tag ttag -> walk_ty_tag v ttag
|
| Ast.TY_tag ttag -> walk_ty_tag v ttag
|
||||||
| Ast.TY_iso tiso -> Array.iter (walk_ty_tag v) tiso.Ast.iso_group
|
| Ast.TY_iso tiso -> Array.iter (walk_ty_tag v) tiso.Ast.iso_group
|
||||||
| Ast.TY_fn tfn -> walk_ty_fn v tfn
|
| Ast.TY_fn tfn -> walk_ty_fn v tfn
|
||||||
|
@ -301,6 +301,8 @@ and walk_ty
|
||||||
| Ast.TY_nil -> ()
|
| Ast.TY_nil -> ()
|
||||||
| Ast.TY_task -> ()
|
| Ast.TY_task -> ()
|
||||||
| Ast.TY_any -> ()
|
| Ast.TY_any -> ()
|
||||||
|
| Ast.TY_exterior m -> walk_ty v m
|
||||||
|
| Ast.TY_mutable m -> walk_ty v m
|
||||||
in
|
in
|
||||||
walk_bracketed
|
walk_bracketed
|
||||||
v.visit_ty_pre
|
v.visit_ty_pre
|
||||||
|
@ -448,16 +450,16 @@ and walk_stmt
|
||||||
|
|
||||||
| Ast.STMT_init_rec (lv, atab, base) ->
|
| Ast.STMT_init_rec (lv, atab, base) ->
|
||||||
walk_lval v lv;
|
walk_lval v lv;
|
||||||
Array.iter (fun (_, _, _, a) -> walk_atom v a) atab;
|
Array.iter (fun (_, a) -> walk_atom v a) atab;
|
||||||
walk_option (walk_lval v) base;
|
walk_option (walk_lval v) base;
|
||||||
|
|
||||||
| Ast.STMT_init_vec (lv, _, atoms) ->
|
| Ast.STMT_init_vec (lv, atoms) ->
|
||||||
walk_lval v lv;
|
walk_lval v lv;
|
||||||
Array.iter (walk_atom v) atoms
|
Array.iter (walk_atom v) atoms
|
||||||
|
|
||||||
| Ast.STMT_init_tup (lv, mut_atoms) ->
|
| Ast.STMT_init_tup (lv, mut_atoms) ->
|
||||||
walk_lval v lv;
|
walk_lval v lv;
|
||||||
Array.iter (fun (_, _, a) -> walk_atom v a) mut_atoms
|
Array.iter (walk_atom v) mut_atoms
|
||||||
|
|
||||||
| Ast.STMT_init_str (lv, _) ->
|
| Ast.STMT_init_str (lv, _) ->
|
||||||
walk_lval v lv
|
walk_lval v lv
|
||||||
|
@ -469,6 +471,10 @@ and walk_stmt
|
||||||
walk_option (walk_lval v) port;
|
walk_option (walk_lval v) port;
|
||||||
walk_lval v chan;
|
walk_lval v chan;
|
||||||
|
|
||||||
|
| Ast.STMT_init_exterior (dst, src) ->
|
||||||
|
walk_lval v dst;
|
||||||
|
walk_atom v src
|
||||||
|
|
||||||
| Ast.STMT_for f ->
|
| Ast.STMT_for f ->
|
||||||
walk_stmt_for f
|
walk_stmt_for f
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue