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
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
open Xi_lib
open Ir
let i32_0 = Int32.of_int 0
let i32_1 = Int32.of_int 1
(* --------------------------------------------------- *)
module Make() = struct
module Environment = struct
type env = Env of
{ procmap: procid Ast.IdMap.t
; varmap: reg Ast.IdMap.t
}
let empty =
let procmap = Ast.IdMap.empty in
let varmap = Ast.IdMap.empty in
Env {procmap; varmap}
let add_proc id procid (Env {procmap; varmap}) =
let procmap = Ast.IdMap.add id procid procmap in
Env {procmap; varmap}
let add_var id reg (Env {procmap; varmap}) =
let varmap = Ast.IdMap.add id reg varmap in
Env {procmap; varmap}
let lookup_proc id (Env {procmap; _}) =
try
Ast.IdMap.find id procmap
with Not_found ->
failwith @@ Format.sprintf "Unknown procedure identifier: %s" (Ast.string_of_identifier id)
let lookup_var id (Env {varmap; _}) =
try
Ast.IdMap.find id varmap
with Not_found ->
failwith @@ Format.sprintf "Unknown variable identifier: %s" (Ast.string_of_identifier id)
end
(* --------------------------------------------------- *)
module Scanner = struct
let mangle_id id =
Format.sprintf "_I_%s" (Ast.string_of_identifier id)
let rec mangle_texpr = function
| Ast.TEXPR_Int _ -> "i"
| Ast.TEXPR_Bool _ -> "b"
| Ast.TEXPR_Array {sub;_} -> "a" ^ mangle_texpr sub
let mangle_var_declaration v = mangle_texpr @@ Ast.type_expression_of_var_declaration v
let mangle_formal_parameters xs = String.concat "" (List.map mangle_var_declaration xs)
let mangle_return_types xs = String.concat "" (List.map mangle_texpr xs)
let scan_global_declaration (env, symbols) = function
| Ast.GDECL_Function {id; formal_parameters; return_types; _} ->
let name = Format.sprintf "%s_%s_%s"
(mangle_id id) (mangle_formal_parameters formal_parameters) (mangle_return_types return_types)
in
Environment.add_proc id (Procid name) env, Procid name :: symbols
let scan_module env (Ast.ModuleDefinition {global_declarations; _}) =
List.fold_left scan_global_declaration (env, []) global_declarations
end
(* --------------------------------------------------- *)
module type SContext = sig
val cfg : ControlFlowGraph.t
val node2type: (Ast.node_tag, Types.normal_type) Hashtbl.t
val allocate_register: unit -> reg
end
(* --------------------------------------------------- *)
module Translator(M:SContext) = struct
open M
(* dodaj instrukcje do bloku *)
let append_instruction l i =
let block = ControlFlowGraph.block cfg l in
ControlFlowGraph.set_block cfg l (block @ [i])
(* ustaw terminator na skok bezwarunkowy *)
let set_jump l_from l_to =
ControlFlowGraph.set_terminator cfg l_from @@ T_Jump l_to;
ControlFlowGraph.connect cfg l_from l_to
(* ustaw terminator na powrót-z-procedury *)
let set_return l_from xs =
ControlFlowGraph.set_terminator cfg l_from @@ T_Return xs;
ControlFlowGraph.connect cfg l_from (ControlFlowGraph.exit_label cfg)
(* ustaw terminator na skok warunkowy *)
let set_branch cond a b l_from l_to1 l_to2 =
ControlFlowGraph.set_terminator cfg l_from @@ T_Branch (cond, a, b, l_to1, l_to2);
ControlFlowGraph.connect cfg l_from l_to1;
ControlFlowGraph.connect cfg l_from l_to2
let allocate_block () = ControlFlowGraph.allocate_block cfg
let i32_0 = Int32.of_int 0
let i32_1 = Int32.of_int 1
(* --------------------------------------------------- *)
let rec translate_expression env current_bb = function
| Ast.EXPR_Char {value; _} ->
current_bb, E_Int (Int32.of_int @@ Char.code value)
| Ast.EXPR_Id {id; _} ->
current_bb, E_Reg (Environment.lookup_var id env)
| _ ->
failwith "not yet implemented"
(* --------------------------------------------------- *)
and translate_condition env current_bb else_bb = function
| Ast.EXPR_Bool {value=true; _} ->
current_bb
| Ast.EXPR_Bool {value=false; _} ->
set_jump current_bb else_bb;
allocate_block ()
(* Zaimplementuj dodatkowe przypadki *)
| e ->
let current_bb, res = translate_expression env current_bb e in
let next_bb = allocate_block () in
set_branch COND_Ne res (E_Int i32_0) current_bb next_bb else_bb;
next_bb
(* --------------------------------------------------- *)
let rec translate_statement env current_bb = function
| _ ->
failwith "not yet implemented"
and translate_block env current_bb (Ast.STMTBlock {body; _}) =
failwith "not yet implemented"
let bind_var_declaration env vardecl =
let r = allocate_register () in
let env = Environment.add_var (Ast.identifier_of_var_declaration vardecl) r env in
env, r
let bind_formal_parameters env xs =
let f env x = fst (bind_var_declaration env x) in
List.fold_left f env xs
let translate_global_definition env = function
| Ast.GDECL_Function {id; body=Some body; formal_parameters;_} ->
let procid = Environment.lookup_proc id env in
let frame_size = 0 in
let env = bind_formal_parameters env formal_parameters in
let formal_parameters = List.length formal_parameters in
let proc = Procedure {procid; cfg; frame_size; allocate_register; formal_parameters} in
let first_bb = allocate_block () in
let _, last_bb = translate_block env first_bb body in
ControlFlowGraph.connect cfg last_bb (ControlFlowGraph.exit_label cfg);
ControlFlowGraph.connect cfg (ControlFlowGraph.entry_label cfg) first_bb;
[proc]
| _ ->
[]
end
let make_allocate_register () =
let counter = ref 0 in
fun () ->
let i = !counter in
incr counter;
REG_Tmp i
let translate_global_definition node2type env gdef =
let cfg = ControlFlowGraph.create () in
let module T = Translator(struct
let cfg = cfg
let node2type = node2type
let allocate_register = make_allocate_register ()
end) in
T.translate_global_definition env gdef
let translate_module node2type env (Ast.ModuleDefinition {global_declarations; _}) =
List.flatten @@ List.map (translate_global_definition node2type env) global_declarations
let translate_module mdef node2type =
let env = Environment.empty in
let env, symbols = Scanner.scan_module env mdef in
let procedures = translate_module node2type env mdef in
Program {procedures; symbols}
end
|
