comparison lab3/kgen.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:bfdcc3820b32
1 (* lab3/kgen.ml *)
2 (* Copyright (c) 2017 J. M. Spivey *)
3
4 open Tree
5 open Dict
6 open Keiko
7 open Print
8
9 let optflag = ref false
10
11 let level = ref 0
12
13 let slink = 12
14
15 (* |gen_addr| -- generate code to push address of a variable *)
16 let gen_addr d =
17 if d.d_level = 0 then
18 GLOBAL d.d_lab
19 else
20 failwith "local variables not implemented yet"
21
22 (* |gen_expr| -- generate code for an expression *)
23 let rec gen_expr =
24 function
25 Variable x ->
26 let d = get_def x in
27 begin
28 match d.d_kind with
29 VarDef ->
30 SEQ [LINE x.x_line; gen_addr d; LOADW]
31 | ProcDef nargs ->
32 failwith "no procedure values"
33 end
34 | Constant x ->
35 CONST x
36 | Monop (w, e1) ->
37 SEQ [gen_expr e1; MONOP w]
38 | Binop (w, e1, e2) ->
39 SEQ [gen_expr e1; gen_expr e2; BINOP w]
40 | Call (p, args) ->
41 SEQ [LINE p.x_line;
42 failwith "no procedure call"]
43
44 (* |gen_cond| -- generate code for short-circuit condition *)
45 let rec gen_cond e tlab flab =
46 (* Jump to |tlab| if |e| is true and |flab| if it is false *)
47 match e with
48 Constant x ->
49 if x <> 0 then JUMP tlab else JUMP flab
50 | Binop ((Eq|Neq|Lt|Gt|Leq|Geq) as w, e1, e2) ->
51 SEQ [gen_expr e1; gen_expr e2;
52 JUMPC (w, tlab); JUMP flab]
53 | Monop (Not, e1) ->
54 gen_cond e1 flab tlab
55 | Binop (And, e1, e2) ->
56 let lab1 = label () in
57 SEQ [gen_cond e1 lab1 flab; LABEL lab1; gen_cond e2 tlab flab]
58 | Binop (Or, e1, e2) ->
59 let lab1 = label () in
60 SEQ [gen_cond e1 tlab lab1; LABEL lab1; gen_cond e2 tlab flab]
61 | _ ->
62 SEQ [gen_expr e; CONST 0; JUMPC (Neq, tlab); JUMP flab]
63
64 (* |gen_stmt| -- generate code for a statement *)
65 let rec gen_stmt =
66 function
67 Skip -> NOP
68 | Seq ss ->
69 SEQ (List.map gen_stmt ss)
70 | Assign (v, e) ->
71 let d = get_def v in
72 begin
73 match d.d_kind with
74 VarDef ->
75 SEQ [gen_expr e; gen_addr d; STOREW]
76 | _ -> failwith "assign"
77 end
78 | Print e ->
79 SEQ [gen_expr e; CONST 0; GLOBAL "lib.print"; PCALL 1]
80 | Newline ->
81 SEQ [CONST 0; GLOBAL "lib.newline"; PCALL 0]
82 | IfStmt (test, thenpt, elsept) ->
83 let lab1 = label () and lab2 = label () and lab3 = label () in
84 SEQ [gen_cond test lab1 lab2;
85 LABEL lab1; gen_stmt thenpt; JUMP lab3;
86 LABEL lab2; gen_stmt elsept; LABEL lab3]
87 | WhileStmt (test, body) ->
88 let lab1 = label () and lab2 = label () and lab3 = label () in
89 SEQ [JUMP lab2; LABEL lab1; gen_stmt body;
90 LABEL lab2; gen_cond test lab1 lab3; LABEL lab3]
91 | Return e ->
92 failwith "no return statement"
93
94 (* |gen_proc| -- generate code for a procedure *)
95 let rec gen_proc (Proc (p, formals, Block (vars, procs, body))) =
96 let d = get_def p in
97 level := d.d_level;
98 let code = gen_stmt body in
99 printf "PROC $ $ 0 0\n" [fStr d.d_lab; fNum (4 * List.length vars)];
100 Keiko.output (if !optflag then Peepopt.optimise code else code);
101 printf "ERROR E_RETURN 0\n" [];
102 printf "END\n\n" [];
103 List.iter gen_proc procs
104
105 (* |translate| -- generate code for the whole program *)
106 let translate (Program (Block (vars, procs, body))) =
107 level := 0;
108 printf "PROC MAIN 0 0 0\n" [];
109 Keiko.output (gen_stmt body);
110 printf "RETURN\n" [];
111 printf "END\n\n" [];
112 List.iter gen_proc procs;
113 List.iter (function x -> printf "GLOVAR _$ 4\n" [fStr x]) vars