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
|
(*
* UPEM / L3 / Functional programming / Project: URM
* Pacien TRAN-GIRARD, Adam NAILI
*)
open Common
let end_label = "end"
let compile_preprocess =
let rec id_from_name tbl name = match Hashtbl.find_opt tbl name with
| Some(id) -> id
| None -> let new_id = string_of_int (Hashtbl.length tbl) in Hashtbl.add tbl name new_id; new_id
and aux tbl = function
| [] -> [ Label(end_label) ]
| Comment(_) :: tail -> aux tbl tail
| Label(name) :: tail -> Label(id_from_name tbl name) :: aux tbl tail
| EqPredicate(i, j, name) :: tail -> EqPredicate(i, j, id_from_name tbl name) :: aux tbl tail
| GEqPredicate(i, j, name) :: tail -> GEqPredicate(i, j, id_from_name tbl name) :: aux tbl tail
| GTPredicate(i, j, name) :: tail -> GTPredicate(i, j, id_from_name tbl name) :: aux tbl tail
| LEqPredicate(i, j, name) :: tail -> LEqPredicate(i, j, id_from_name tbl name) :: aux tbl tail
| LTPredicate(i, j, name) :: tail -> LTPredicate(i, j, id_from_name tbl name) :: aux tbl tail
| ZeroPredicate(i, name) :: tail -> ZeroPredicate(i, id_from_name tbl name) :: aux tbl tail
| Goto(name) :: tail -> Goto(id_from_name tbl name) :: aux tbl tail
| any :: tail -> any :: aux tbl tail
in aux (Hashtbl.create 100)
let build_initial_state eurmcmds =
let max_reg_of_instr = function
| Dec(r) | Inc(r) | Zero(r) | ZeroPredicate(r, _) -> r
| Add(r1, r2) | Copy(r1, r2) | Mult(r1, r2) | Sub(r1, r2)
| EqPredicate(r1, r2, _) | GEqPredicate(r1, r2, _) | GTPredicate(r1, r2, _)
| LEqPredicate(r1, r2, _) | LTPredicate(r1, r2, _) -> max r1 r2
| _ -> 0
in
{ max_reg = List.fold_left (fun acc instr -> max acc (max_reg_of_instr instr)) 0 eurmcmds;
label_count = List.fold_left (fun acc instr -> acc + (match instr with | Label(_) -> 1 | _ -> 0)) 0 eurmcmds;
label_table = Hashtbl.create 100 }
let add_reg_label state new_regs new_labels =
{ max_reg = state.max_reg + new_regs;
label_count = state.label_count + new_labels;
label_table = state.label_table }
let make_reg state offset = state.max_reg + offset
let make_label state offset = string_of_int (state.label_count + offset)
let rec apply_transform transform_func state = function
| [] -> [], state
| cmd :: tail ->
let substitution, new_state = transform_func state cmd
in let prgm_tail, end_state = apply_transform transform_func new_state tail
in substitution @ prgm_tail, end_state
let compile_stage1 eurmcmds state =
let transform state = function
| Dec(r) ->
let new_reg = make_reg state 1
in [ Zero(new_reg); Inc(new_reg); Sub(r, new_reg) ],
add_reg_label state 1 0
| GEqPredicate(r1, r2, l) ->
let new_reg = make_reg state 1
in [ Copy(new_reg, r1); Inc(new_reg); GTPredicate(new_reg, r2, l) ],
add_reg_label state 1 0
| LEqPredicate(r1, r2, l) ->
let new_reg = make_reg state 1
in [ Copy(new_reg, r2); Inc(new_reg); GTPredicate(new_reg, r1, l) ],
add_reg_label state 1 0
| Mult(r1, r2) ->
let ctr_reg = make_reg state 1 and res_reg = make_reg state 2
and start_label = make_label state 1 and end_label = make_label state 2
in [ Zero(ctr_reg); Zero(res_reg); Label(start_label); EqPredicate(ctr_reg, r2, end_label);
Add(res_reg, r1); Inc(ctr_reg); Goto(start_label); Label(end_label); Copy(r1, res_reg) ],
add_reg_label state 2 2
| ZeroPredicate(r, l) ->
let new_reg = make_reg state 1
in [ Zero(new_reg); EqPredicate(r, new_reg, l) ],
add_reg_label state 1 0
| LTPredicate(r1, r2, l) -> [ GTPredicate(r2, r1, l) ], state
| any -> [ any ], state
in apply_transform (transform) state eurmcmds
let compile_stage2 eurmcmds state =
let transform state = function
| Add(r1, r2) ->
let ctr_reg = make_reg state 1
and start_label = make_label state 1 and end_label = make_label state 2
in [ Zero(ctr_reg); Label(start_label); EqPredicate(ctr_reg, r2, end_label);
Inc(r1); Inc(ctr_reg); Goto(start_label); Label(end_label) ],
add_reg_label state 1 2
| GTPredicate(r1, r2, l) ->
let aux_reg = make_reg state 1
and start_label = make_label state 1 and end_label = make_label state 2
in [ Zero(aux_reg); Label(start_label); EqPredicate(aux_reg, r1, end_label); EqPredicate(aux_reg, r2, l);
Inc(aux_reg); Goto(start_label); Label(end_label) ],
add_reg_label state 1 2
| Sub(r1, r2) ->
let diff_reg = make_reg state 1 and aux1_reg = make_reg state 2 and aux2_reg = make_reg state 3
and start_label = make_label state 1 and end_label = make_label state 2
and error_label = make_label state 3
in [ Zero(diff_reg); Copy(aux1_reg, r1); Copy(aux2_reg, r2); Label(start_label);
EqPredicate(aux1_reg, r2, error_label); EqPredicate(aux2_reg, r1, end_label);
Inc(diff_reg); Inc(aux1_reg); Inc(aux2_reg); Goto(start_label);
Label(error_label); Quit; Label(end_label); Copy(r1, diff_reg) ],
add_reg_label state 3 3
| Quit -> [ Goto(end_label) ], state
| any -> [ any ], state
in apply_transform (transform) state eurmcmds
let compile_stage3 eurmcmds state =
let transform state = function
| Goto(lbl) ->
let dummy_reg = make_reg state 1
in [ Zero(dummy_reg); EqPredicate(dummy_reg, dummy_reg, lbl) ],
add_reg_label state 1 0
| any -> [ any ], state
in apply_transform (transform) state eurmcmds
let compile_stage4 eurmcmds state =
let build_label_table state eurmcmds=
List.iteri (fun lineo cmd -> match cmd with | Label(lbl) -> Hashtbl.add state.label_table lbl lineo | _ -> ()) eurmcmds; state
in let transform state = function
| Inc(r) -> [ URMSucc(r) ], state
| Zero(r) -> [ URMZero(r) ], state
| Copy(r1, r2) -> [ URMCopy(r1, r2) ], state
| EqPredicate(r1, r2, lbl) -> [ URMJump(r1, r2, Hashtbl.find state.label_table lbl) ], state
| Label(_) ->
let dummy_reg = make_reg state 1
in [ URMZero(dummy_reg) ], add_reg_label state 1 0
| _ -> failwith "Invalid_argument"
in apply_transform (transform) (build_label_table state eurmcmds) eurmcmds
let urm_from_eurm eurmcmds =
let chain transform (eurmcmds, compile_state) = transform eurmcmds compile_state
in (compile_preprocess eurmcmds, build_initial_state eurmcmds)
|> chain compile_stage1
|> chain compile_stage2
|> chain compile_stage3
|> chain compile_stage4
|> fst
|