1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
open Semant;;
open Common;;
let log cx = Session.log "alias"
(should_log cx cx.ctxt_sess.Session.sess_log_alias)
cx.ctxt_sess.Session.sess_log_out
;;
let alias_analysis_visitor
(cx:ctxt)
(inner:Walk.visitor)
: Walk.visitor =
let curr_stmt = Stack.create () in
let alias_slot (slot_id:node_id) : unit =
begin
log cx "noting slot #%d as aliased" (int_of_node slot_id);
Hashtbl.replace cx.ctxt_slot_aliased slot_id ()
end
in
let alias lval =
let defn_id = lval_base_defn_id cx lval in
if (defn_id_is_slot cx defn_id)
then alias_slot defn_id
in
let alias_atom at =
match at with
Ast.ATOM_lval lv -> alias lv
| _ -> () (* Aliasing a literal is harmless, if weird. *)
in
let alias_call_args dst callee args =
alias dst;
let callee_ty = lval_ty cx callee in
match callee_ty with
Ast.TY_fn (tsig,_) ->
Array.iteri
begin
fun i slot ->
match slot.Ast.slot_mode with
Ast.MODE_alias ->
alias_atom args.(i)
| _ -> ()
end
tsig.Ast.sig_input_slots
| _ -> ()
in
let check_no_alias_bindings
(fn:Ast.lval)
(args:(Ast.atom option) array)
: unit =
let fty = match lval_ty cx fn with
Ast.TY_fn tfn -> tfn
| _ -> err (Some (lval_base_id fn)) "binding non-fn"
in
let arg_slots = (fst fty).Ast.sig_input_slots in
Array.iteri
begin
fun i arg ->
match arg with
None -> ()
| Some _ ->
match arg_slots.(i).Ast.slot_mode with
Ast.MODE_local -> ()
| Ast.MODE_alias ->
err (Some (lval_base_id fn)) "binding alias slot"
end
args
in
let visit_stmt_pre s =
Stack.push s.id curr_stmt;
begin
try
match s.node with
(* FIXME (issue #26): actually all these *existing* cases
* can probably go now that we're using Trans.aliasing to
* form short-term spill-based aliases. Only aliases that
* survive 'into' a sub-block (those formed during iteration)
* need to be handled in this module. *)
Ast.STMT_call (dst, callee, args)
| Ast.STMT_spawn (dst, _, _, callee, args)
-> alias_call_args dst callee args
| Ast.STMT_bind (_, fn, args) ->
check_no_alias_bindings fn args
| Ast.STMT_send (_, src) -> alias src
| Ast.STMT_recv (dst, _) -> alias dst
| Ast.STMT_new_port (dst) -> alias dst
| Ast.STMT_new_chan (dst, _) -> alias dst
| Ast.STMT_new_vec (dst, _, _) -> alias dst
| Ast.STMT_new_str (dst, _) -> alias dst
| Ast.STMT_for_each sfe ->
let (slot, _) = sfe.Ast.for_each_slot in
alias_slot slot.id
| _ -> () (* FIXME (issue #29): plenty more to handle here. *)
with
Semant_err (None, msg) ->
raise (Semant_err ((Some s.id), msg))
end;
inner.Walk.visit_stmt_pre s
in
let visit_stmt_post s =
inner.Walk.visit_stmt_post s;
ignore (Stack.pop curr_stmt);
in
let visit_lval_pre lv =
let slot_id = lval_base_defn_id cx lv in
if (not (Stack.is_empty curr_stmt)) && (defn_id_is_slot cx slot_id)
then
begin
let slot_depth = get_slot_depth cx slot_id in
let stmt_depth = get_stmt_depth cx (Stack.top curr_stmt) in
if slot_depth <> stmt_depth
then
begin
let _ = assert (slot_depth < stmt_depth) in
alias_slot slot_id
end
end
in
{ inner with
Walk.visit_stmt_pre = visit_stmt_pre;
Walk.visit_stmt_post = visit_stmt_post;
Walk.visit_lval_pre = visit_lval_pre
}
;;
let process_crate
(cx:ctxt)
(crate:Ast.crate)
: unit =
let passes =
[|
(alias_analysis_visitor cx
Walk.empty_visitor);
|]
in
run_passes cx "alias" passes
cx.ctxt_sess.Session.sess_log_alias log crate
;;
(*
* Local Variables:
* fill-column: 78;
* indent-tabs-mode: nil
* buffer-file-coding-system: utf-8-unix
* compile-command: "make -k -C $RBUILD 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)
|