annotate ppc/kgen.ml @ 0:bfdcc3820b32

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 05 Oct 2017 08:04:15 +0100
parents
children
rev   line source
0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
1 (* ppc/kgen.ml *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
2 (* Copyright (c) 2017 J. M. Spivey *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
3
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
4 open Dict
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
5 open Tree
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
6 open Mach
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
7 open Keiko
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
8 open Lexer
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
9 open Print
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
10
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
11 (* This code generator is a bit more like a functional program,
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
12 because each generation routine returns a list of instructions,
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
13 represented using the SEQ constructor of Keiko.inst *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
14
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
15 let optflag = ref false
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
16 let boundchk = ref false
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
17
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
18 (* |level| -- nesting level of current procedure *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
19 let level = ref 0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
20
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
21 (* |size_of| -- calculate size of type *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
22 let size_of t = t.t_rep.r_size
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
23
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
24 (* |count_of| -- calculate number of parameter words *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
25 let count_of t = if t.t_rep.r_size = 0 then 0 else 1
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
26
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
27 (* |is_const| -- test if expression is a constant *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
28 let is_const e = (e.e_value <> None)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
29
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
30 (* |get_value| -- get constant value or fail *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
31 let get_value e =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
32 match e.e_value with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
33 Some v -> v
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
34 | None -> failwith "get_value"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
35
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
36 (* |arg_size| -- compute size of argument *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
37 let arg_size f =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
38 match f.d_kind with PParamDef -> 2 | _ -> 1
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
39
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
40 (* |line_number| -- compute line number of variable for bound check *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
41 let rec line_number v =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
42 match v.e_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
43 Variable x -> x.x_line
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
44 | Sub (a, i) -> line_number a
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
45 | Select (r, x) -> x.x_line
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
46 | Deref p -> line_number p
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
47 | _ -> failwith "line_number"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
48
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
49 let load_addr = LOAD addr_rep.r_size
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
50
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
51 (* |schain| -- code to follow N links of static chain *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
52 let schain n =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
53 if n = 0 then
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
54 LOCAL 0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
55 else
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
56 SEQ [LOCAL stat_link; load_addr;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
57 SEQ (Util.copy (n-1) (SEQ [CONST stat_link; OFFSET; load_addr]))]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
58
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
59 (* |address| -- code to push address of an object *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
60 let address d =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
61 match d.d_addr with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
62 Global g -> GLOBAL g
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
63 | Local off ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
64 if d.d_level = !level then
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
65 LOCAL off
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
66 else
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
67 SEQ [schain (!level - d.d_level); CONST off; OFFSET]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
68 | _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
69 failwith (sprintf "address $" [fId d.d_tag])
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
70
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
71 (* |gen_closure| -- push a (code, envt) pair *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
72 let gen_closure d =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
73 match d.d_kind with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
74 ProcDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
75 let statlink =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
76 if d.d_level = 0 then CONST 0
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
77 else schain (!level - d.d_level) in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
78 SEQ [statlink; address d]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
79 | PParamDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
80 SEQ [address d; CONST addr_rep.r_size; OFFSET; load_addr;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
81 address d; load_addr]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
82 | _ -> failwith "missing closure"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
83
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
84 (* |gen_addr| -- code for the address of a variable *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
85 let rec gen_addr v =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
86 match v.e_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
87 Variable x ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
88 let d = get_def x in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
89 begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
90 match d.d_kind with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
91 VarDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
92 address d
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
93 | VParamDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
94 SEQ [address d; load_addr]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
95 | CParamDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
96 if scalar d.d_type || is_pointer d.d_type then
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
97 address d
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
98 else
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
99 SEQ [address d; load_addr]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
100 | StringDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
101 address d
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
102 | _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
103 failwith "load_addr"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
104 end
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
105 | Sub (a, i) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
106 SEQ [gen_addr a; gen_expr i;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
107 if !boundchk then
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
108 SEQ [CONST (bound a.e_type); BOUND (line_number a)]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
109 else
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
110 NOP;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
111 CONST (size_of v.e_type); BINOP Times; OFFSET]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
112 | Select (r, x) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
113 let d = get_def x in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
114 SEQ [gen_addr r; CONST (offset_of d); OFFSET]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
115 | Deref p ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
116 SEQ [gen_expr p;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
117 if !boundchk then NCHECK (line_number p) else NOP]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
118 | String (lab, n) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
119 GLOBAL lab
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
120 | _ -> failwith "gen_addr"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
121
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
122 (* |gen_expr| -- tree for the value of an expression *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
123 and gen_expr e =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
124 match e.e_value with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
125 Some v ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
126 CONST v
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
127 | None ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
128 begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
129 match e.e_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
130 Variable _ | Sub _ | Select _ | Deref _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
131 SEQ [gen_addr e; LOAD (size_of e.e_type)]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
132 | (Monop (Not, _) | Binop ((And|Or), _, _) ) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
133 gen_cond_expr e
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
134 | Monop (w, e1) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
135 SEQ [gen_expr e1; MONOP w]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
136 | Binop (w, e1, e2) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
137 SEQ [gen_expr e1; gen_expr e2; BINOP w]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
138 | FuncCall (p, args) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
139 gen_call p args
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
140 | _ -> failwith "gen_expr"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
141 end
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
142
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
143 (* |gen_call| -- generate code to call a procedure *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
144 and gen_call x args =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
145 let d = get_def x in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
146 match d.d_kind with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
147 LibDef q ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
148 gen_libcall q args
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
149 | _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
150 let p = get_proc d.d_type in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
151 SEQ [
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
152 SEQ (List.map gen_arg (List.rev (List.combine p.p_fparams args)));
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
153 gen_closure d;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
154 PCALL (p.p_pcount, count_of p.p_result)]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
155
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
156 (* |gen_arg| -- generate code to push a procedure argument *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
157 and gen_arg (f, a) =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
158 match f.d_kind with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
159 CParamDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
160 if scalar f.d_type || is_pointer f.d_type then
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
161 gen_expr a
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
162 else
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
163 gen_addr a
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
164 | VParamDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
165 gen_addr a
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
166 | PParamDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
167 begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
168 match a.e_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
169 Variable x ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
170 gen_closure (get_def x)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
171 | _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
172 failwith "bad funarg"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
173 end
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
174 | _ -> failwith "bad arg"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
175
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
176 (* |gen_libcall| -- generate code to call a built-in procedure *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
177 and gen_libcall q args =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
178 let libcall lab n rt =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
179 SEQ [CONST 0; GLOBAL lab; PCALL (n, count_of rt)] in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
180 match (q.q_id, args) with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
181 ((ChrFun|OrdFun), [e]) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
182 gen_expr e
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
183 | (PrintString, [e]) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
184 SEQ [CONST (bound e.e_type); gen_addr e;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
185 libcall "lib.print_string" 2 voidtype]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
186 | (ReadChar, [e]) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
187 SEQ [gen_addr e; libcall "lib.read_char" 1 voidtype]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
188 | (NewProc, [e]) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
189 let size = size_of (base_type e.e_type) in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
190 SEQ [CONST size; libcall "lib.new" 1 addrtype; gen_addr e;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
191 STORE addr_rep.r_size]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
192 | (ArgcFun, []) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
193 libcall "lib.argc" 0 integer
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
194 | (ArgvProc, [e1; e2]) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
195 SEQ [gen_addr e2; gen_expr e1; libcall "lib.argv" 2 voidtype]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
196 | (OpenIn, [e]) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
197 SEQ [gen_addr e; libcall "lib.open_in" 1 voidtype]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
198 | (Operator op, [e1]) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
199 SEQ [gen_expr e1; MONOP op]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
200 | (Operator op, [e1; e2]) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
201 SEQ [gen_expr e1; gen_expr e2; BINOP op]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
202 | (_, _) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
203 let proc = sprintf "lib.$" [fLibId q.q_id] in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
204 SEQ [SEQ (List.map gen_expr (List.rev args));
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
205 libcall proc (List.length args) voidtype]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
206
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
207 (* |gen_cond| -- generate code to branch on a condition *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
208 and gen_cond tlab flab test =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
209 match test.e_value with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
210 Some v ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
211 if v <> 0 then JUMP tlab else JUMP flab
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
212 | None ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
213 begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
214 match test.e_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
215 Monop (Not, e) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
216 gen_cond flab tlab e
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
217 | Binop (And, e1, e2) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
218 let lab1 = label () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
219 SEQ [gen_cond lab1 flab e1; LABEL lab1; gen_cond tlab flab e2]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
220 | Binop (Or, e1, e2) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
221 let lab1 = label () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
222 SEQ [gen_cond tlab lab1 e1; LABEL lab1; gen_cond tlab flab e2]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
223 | Binop ((Eq | Neq | Lt | Leq | Gt | Geq) as w, e1, e2) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
224 SEQ [gen_expr e1; gen_expr e2; JUMPC (w, tlab); JUMP flab]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
225 | _ ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
226 SEQ [gen_expr test; CONST 0; JUMPC (Neq, tlab); JUMP flab]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
227 end
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
228
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
229 (* |gen_cond_expr| -- generate short-cicuit expression with boolean result *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
230 and gen_cond_expr test =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
231 let l1 = label () and l2 = label () and l3 = label () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
232 SEQ [gen_cond l1 l2 test;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
233 LABEL l1; CONST 1; JUMP l3; LABEL l2; CONST 0; LABEL l3]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
234
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
235 let gen_jtable tab0 deflab =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
236 if tab0 = [] then JUMP deflab else begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
237 let table = List.sort (fun (v1, l1) (v2, l2) -> compare v1 v2) tab0 in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
238 let lob = fst (List.hd table) in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
239 let rec tab u qs =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
240 match qs with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
241 [] -> []
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
242 | (v, l) :: rs ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
243 if u = v then l :: tab (v+1) rs else deflab :: tab (u+1) qs in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
244 SEQ [CONST lob; BINOP Minus; JCASE (tab lob table); JUMP deflab]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
245 end
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
246
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
247 (* |gen_stmt| -- generate code for a statement *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
248 let rec gen_stmt s =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
249 let code =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
250 match s.s_guts with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
251 Skip -> NOP
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
252 | Seq ss -> SEQ (List.map gen_stmt ss)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
253 | Assign (v, e) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
254 if scalar v.e_type || is_pointer v.e_type then
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
255 SEQ [gen_expr e; gen_addr v; STORE (size_of v.e_type)]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
256 else
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
257 SEQ [gen_addr v; gen_addr e;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
258 CONST (size_of v.e_type); FIXCOPY]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
259 | ProcCall (p, args) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
260 gen_call p args
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
261 | Return res ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
262 begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
263 match res with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
264 Some e -> SEQ [gen_expr e; RETURN 1]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
265 | None -> SEQ [RETURN 0]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
266 end
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
267 | IfStmt (test, thenpt, elsept) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
268 let lab1 = label () and lab2 = label () and lab3 = label () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
269 SEQ [gen_cond lab1 lab2 test;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
270 LABEL lab1; gen_stmt thenpt; JUMP lab3;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
271 LABEL lab2; gen_stmt elsept; LABEL lab3]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
272 | WhileStmt (test, body) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
273 let lab1 = label () and lab2 = label () and lab3 = label () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
274 SEQ [JUMP lab2; LABEL lab1; gen_stmt body;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
275 LABEL lab2; gen_cond lab1 lab3 test; LABEL lab3]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
276 | RepeatStmt (body, test) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
277 let lab1 = label () and lab2 = label () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
278 SEQ [LABEL lab1; gen_stmt body;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
279 gen_cond lab2 lab1 test; LABEL lab2]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
280 | ForStmt (var, lo, hi, body) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
281 (* For simplicity, this code re-evaluates hi on each iteration *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
282 let l1 = label () and l2 = label () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
283 let s = int_rep.r_size in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
284 SEQ [gen_expr lo; gen_addr var; STORE s; JUMP l2;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
285 LABEL l1; gen_stmt body;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
286 gen_expr var; CONST 1; BINOP Plus; gen_addr var; STORE s;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
287 LABEL l2; gen_expr var; gen_expr hi; JUMPC (Leq, l1)]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
288 | CaseStmt (sel, arms, deflt) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
289 let deflab = label () and donelab = label () in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
290 let labs = List.map (function x -> label ()) arms in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
291 let get_val (v, body) = get_value v in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
292 let table = List.combine (List.map get_val arms) labs in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
293 let gen_case lab (v, body) =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
294 SEQ [LABEL lab; gen_stmt body; JUMP donelab] in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
295 SEQ [gen_expr sel; gen_jtable table deflab;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
296 SEQ (List.map2 gen_case labs arms);
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
297 LABEL deflab; gen_stmt deflt;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
298 LABEL donelab] in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
299 SEQ [if s.s_line <> 0 then LINE s.s_line else NOP; code]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
300
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
301 (* |do_proc| -- generate code for a procedure *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
302 let do_proc lab lev rtype fsize body =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
303 printf "PROC $ $ 0 0\n" [fStr lab; fNum fsize];
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
304 level := lev+1;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
305 let code =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
306 SEQ [gen_stmt body;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
307 (if rtype.t_rep.r_size = 0 then RETURN 0 else ERETURN 0)] in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
308 Keiko.output (if !optflag then Peepopt.optimise code else code);
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
309 printf "END\n\n" []
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
310
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
311 (* |gen_proc| -- translate a procedure, ignore other declarations *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
312 let rec gen_proc =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
313 function
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
314 ProcDecl (Heading (x, _, _), Block (locals, body, fsize, nregv)) ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
315 let d = get_def x in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
316 let p = get_proc d.d_type in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
317 begin
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
318 match d.d_addr with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
319 Global lab ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
320 do_proc lab d.d_level p.p_result !fsize body;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
321 gen_procs locals
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
322 | _ -> failwith "gen_proc"
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
323 end
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
324 | _ -> ()
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
325
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
326 (* |gen_procs| -- generate code for the procedures in a block *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
327 and gen_procs ds = List.iter gen_proc ds
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
328
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
329 (* |gen_string| -- generate code for a string constant *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
330 let gen_string (lab, s) =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
331 let s' = s ^ "\000" in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
332 printf "! String \"$\"\n" [fStr (String.escaped s)];
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
333 printf "DEFINE $\n" [fStr lab];
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
334 let hex = "0123456789ABCDEF" in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
335 let n = String.length s' and r = ref 0 in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
336 while !r < n do
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
337 let k = min (n - !r) 32 in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
338 printf "STRING " [];
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
339 for i = !r to !r+k-1 do
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
340 let c = int_of_char s'.[i] in
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
341 printf "$$" [fChr (hex.[c / 16]); fChr (hex.[c mod 16])]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
342 done;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
343 printf "\n" [];
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
344 r := !r + k
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
345 done;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
346 printf "\n" []
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
347
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
348 (* |gen_global| -- reserve space for global variables *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
349 let gen_global d =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
350 match d.d_kind with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
351 VarDef ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
352 (match d.d_addr with
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
353 Global lab ->
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
354 printf "GLOVAR $ $\n" [fStr lab; fNum (size_of d.d_type)]
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
355 | _ -> failwith "gen_global")
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
356 | _ -> ()
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
357
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
358 (* |translate| -- generate code for the whole program *)
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
359 let translate (Prog (Block (globals, main, _, _), glodefs)) =
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
360 gen_procs globals;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
361 do_proc "MAIN" 0 voidtype 0 main;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
362 List.iter gen_global !glodefs;
Mike Spivey <mike@cs.ox.ac.uk>
parents:
diff changeset
363 List.iter gen_string (string_table ())