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
|
open Semant;;
open Common;;
let log cx = Session.log "alias"
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 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_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 path = Stack.create () in
let passes =
[|
(alias_analysis_visitor cx
Walk.empty_visitor);
|]
in
run_passes cx "alias" path 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 ../.. 2>&1 | sed -e 's/\\/x\\//x:\\//g'";
* End:
*)
|