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