-
Notifications
You must be signed in to change notification settings - Fork 0
/
compiler.ml
100 lines (93 loc) · 5.32 KB
/
compiler.ml
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
(* Compiler *)
open Ast
open Utils
exception Error of loc * string
let error loc message = raise (Error (loc,message))
let counter = counter_from 0
let rec compile_expr ?(label = "") e env k li =
let compile_binop_expr e1 e2 prim env k li =
(compile_expr e2 env k li) @ ["PUSH"] @ (compile_expr e1 env (k+1) li) @ ["PRIM " ^ prim]
in
let rec compile_array_expr la env k li loc =
match la with
| [] -> [""]
| [e] -> compile_expr e env k li
| e::es -> compile_expr e env k li @ ["PUSH"] @ compile_array_expr es env k li loc
in
match e with
| Ecst (_,_,(Cbool b)) -> labeled_inst ~label:label (if b then "CONST 1" else "CONST 0") @ li
| Ecst (_,_,(Cint i)) -> labeled_inst ~label:label ("CONST " ^ string_of_int i) @ li
| Ecst (_,_,Cunit) -> labeled_inst ~label:label ("CONST 0") @ li
| Eident (loc,_,(_,i)) ->
if not (List.mem i env) then error loc ("unbound local var: " ^ i);
["ACC " ^ string_of_int ((pos_list env i) + k)] @ li
| Eunop (_,_,Unot,e) -> compile_expr e env k li @ ["PRIM not"] @ li
| Ebinop (_,_,Badd,e1,e2) -> compile_binop_expr e1 e2 "+" env k li @ li
| Ebinop (_,_,Bsub,e1,e2) -> compile_binop_expr e1 e2 "-" env k li @ li
| Ebinop (_,_,Bmul,e1,e2) -> compile_binop_expr e1 e2 "*" env k li @ li
| Ebinop (_,_,Bdiv,e1,e2) -> compile_binop_expr e1 e2 "/" env k li @ li
| Ebinop (_,_,Beq,e1,e2) -> compile_binop_expr e1 e2 "=" env k li @ li
| Ebinop (_,_,Bneq,e1,e2) -> compile_binop_expr e1 e2 "<>" env k li @ li
| Ebinop (_,_,Blt,e1,e2) -> compile_binop_expr e1 e2 "<" env k li @ li
| Ebinop (_,_,Ble,e1,e2) -> compile_binop_expr e1 e2 "<=" env k li @ li
| Ebinop (_,_,Bgt,e1,e2) -> compile_binop_expr e1 e2 ">" env k li @ li
| Ebinop (_,_,Bge,e1,e2) -> compile_binop_expr e1 e2 ">=" env k li @ li
| Ebinop (_,_,Band,e1,e2) -> compile_binop_expr e1 e2 "&" env k li @ li
| Ebinop (_,_,Bor,e1,e2) -> compile_binop_expr e1 e2 "or" env k li @ li
| Eref (_,_,e) -> compile_expr e env k li @ ["MAKEBLOCK 1"] @ li
| Ederef (loc,_,(typ,i)) -> compile_expr (Eident (loc,typ,(typ,i))) env k li @ ["GETFIELD 0"] @ li
| Earray (loc,_,l) -> compile_array_expr (List.rev l) env k li loc @ ["MAKEBLOCK " ^ string_of_int (List.length l)] @ li
| Eaget (loc,ty1,(ty2,i),e) ->
let tmp = "_tmp_" ^ string_of_int (counter ()) in
compile_stmt (Sassign (loc, (ty1,tmp), e, Sif (loc, Ebinop (loc, ty1, Bge, (Eident (loc,ty2,(ty2,tmp))), (Easize (loc,Tint,(ty2,i)))), Sexit, Sskip))) env li @
compile_expr e env k li @ ["PUSH"] @ compile_expr (Eident (loc,ty2,(ty2,i))) env (k+1) li @ ["GETVECTITEM"] @ li
| Easize (loc,_,(typ,i)) -> compile_expr (Eident (loc,typ,(typ,i))) env k li @ ["VECTLENGTH"] @ li
| Erand (loc,typ,e1,e2) ->
(compile_expr e2 env k li) @ ["PUSH"] @ (compile_expr e1 env (k+1) li) @ ["PRIM rand -- TODO"]
and compile_stmt ?(label = "") s env li =
match s with
| Sassign(loc,(_,i),e,s) ->
if List.mem i env then error loc ("local var already bound: " ^ i);
compile_expr e env 0 li @ ["PUSH"] @ compile_stmt s (i :: env) li @ ["POP"]
| Srefassign(loc,(typ,i),e) -> compile_expr e env 0 li @ ["PUSH"] @ compile_expr (Eident (loc,typ,(typ,i))) env 1 li @ ["SETFIELD 0"] @ li
| Saassign(loc,(typ,i),e1,e2) ->
compile_expr e2 env 0 li @ ["PUSH"] @ compile_expr e1 env 1 li @ ["PUSH"] @ compile_expr (Eident (loc,typ,(typ,i))) env 2 li @ ["SETVECTITEM"] @ li
| Sblock b -> compile_block ~label:label b env li
| Sif (_,e,s1,s2) ->
let sct = string_of_int (counter ()) in
compile_expr e env 0 li @ ["BRANCHIFNOT f" ^ sct] @ compile_stmt s1 env li @ ["BRANCH t" ^ sct] @ compile_stmt ~label:("f"^sct) s2 env li @ labeled_inst ~label:("t"^sct) ""
| Swhile (_,e,b) ->
let sct = string_of_int (counter ()) in
compile_expr e env 0 li @ labeled_inst ~label:("wcond"^sct) ("BRANCHIFNOT wdone"^sct) @ compile_block b env li @ compile_expr e env 0 li @ ["BRANCH wcond" ^ sct] @ labeled_inst ~label:("wdone"^sct) ""
| Sfor (loc,s1,e,s2,b) -> compile_stmt s1 env li @ compile_stmt (Swhile (loc,e, Bseq_r (b,s2))) env li
| Sprint e -> (compile_expr ~label:label e env 0 li) @ ["PRIM print"]
| Sprint_ai _ -> [] (* only for abstract interpretation statement *)
| Sprintall_ai _ -> [] (* "" *)
| Sexit -> labeled_inst ~label:label ("STOP") @ li
| Sskip -> labeled_inst ~label:label ("CONST 0") @ li
and compile_block ?(label = "") b env li =
match b with
| Bstmt s -> compile_stmt ~label:label s env li
| Bseq_l (s,b) -> compile_stmt ~label:label s env li @ compile_block ~label:label b env li
| Bseq_r (b,s) -> compile_block ~label:label b env li @ compile_stmt ~label:label s env li
let compile_prog stmt = compile_stmt stmt [] [] @ ["STOP"]
let compile stmt in_file_name =
let oc = open_out ("tests/build/bc_" ^ (Filename.basename in_file_name)) in
let fmt = Format.formatter_of_out_channel oc in
let inst_processing si =
if String.starts_with ~prefix:"LABEL" si then
let sl = String.split_on_char ';' si in
let label_inst = List.hd sl in
let label = String.sub label_inst 6 ((String.length label_inst) - 6) in
let inst = List.nth sl 1 in
Format.fprintf fmt "%s:\n\t%s\n" label inst
else
Format.fprintf fmt "\t%s\n" si
in
let insts_processing li =
let _ = List.map (fun s -> inst_processing s) li in
Format.fprintf fmt "@."
in
let insts = compile_prog stmt in
insts_processing insts;
close_out oc