2 (** This module performs a transformation of a [Clight] program with potentially
3 32 and 16 bits integers to an equivalent [Clight] program that only uses 8
6 The main changes are: defining two types that represent 32 and 16 bits
7 integers with a structure of 8 bits integers, making the substitution,
8 replacing primitive integer operations on 32 and 16 bits integers with new
9 functions emulating them on the new types, and finally defining a global
10 variable for each 32 and 16 bits integer constant, which is then replaced by
11 its associated variable. *)
14 let error_prefix = "Clight32 to Clight8"
15 let error s = Error.global_error error_prefix s
18 let cint32s = Clight.Tint (Clight.I32, AST.Signed)
19 let cint32u = Clight.Tint (Clight.I32, AST.Unsigned)
20 let cint8s = Clight.Tint (Clight.I8, AST.Signed)
21 let cint8u = Clight.Tint (Clight.I8, AST.Unsigned)
24 (* Change the main so that it returns a 8 bits integer. Indeed, 32 bits integers
25 will be replaced by structures, and returning a structure from the main is
26 not Clight compliant. *)
28 let main_ret_type = function
29 | Clight.Tint (_, AST.Signed) -> cint8s
30 | Clight.Tint (_, AST.Unsigned) -> cint8u
31 | _ -> error "The main should return an integer which is not the case."
33 let f_ctype ctype _ = ctype
35 let f_expr_descr ed _ _ = ed
37 let f_stmt ret_type stmt sub_exprs_res sub_stmts_res =
38 match stmt, sub_exprs_res with
39 | Clight.Sreturn (Some _), e :: _ ->
40 let e' = Clight.Expr (Clight.Ecast (ret_type, e), ret_type) in
41 Clight.Sreturn (Some e')
42 | _ -> ClightFold.statement_fill_subs stmt sub_exprs_res sub_stmts_res
44 let body_returns ret_type =
45 ClightFold.statement f_ctype f_expr f_expr_descr (f_stmt ret_type)
47 let fundef_returns_char = function
48 | Clight.Internal cfun ->
49 let ret_type = main_ret_type cfun.Clight.fn_return in
50 let body = body_returns ret_type cfun.Clight.fn_body in
51 Clight.Internal {cfun with Clight.fn_return = ret_type ;
52 Clight.fn_body = body }
53 | Clight.External _ as fundef -> fundef
55 let main_returns_char p = match p.Clight.prog_main with
58 let main_def = List.assoc main p.Clight.prog_funct in
59 let main_def = fundef_returns_char main_def in
61 MiscPottier.update_list_assoc main main_def p.Clight.prog_funct in
62 { p with Clight.prog_funct = prog_funct }
69 (fun stmt1 stmt2 -> Clight.Ssequence (stmt1, stmt2))
72 let is_complex = function
73 | Clight.Tstruct _ | Clight.Tunion _ -> true
76 let is_subst_complex type_substitutions res_type =
77 if List.mem_assoc res_type type_substitutions then
78 is_complex (List.assoc res_type type_substitutions)
81 let addrof_with_type e ctype =
82 let ctype = Clight.Tpointer ctype in
83 (Clight.Expr (Clight.Eaddrof e, ctype), ctype)
85 let address_if_subst_complex type_substitutions =
88 if is_subst_complex type_substitutions ctype then addrof_with_type e ctype
93 let make_call_struct tmpe res_type f_var args args_types =
94 let (res_e, res_type) = addrof_with_type tmpe res_type in
95 let f_type = Clight.Tfunction (res_type :: args_types, Clight.Tvoid) in
96 let f = Clight.Expr (f_var, f_type) in
97 Clight.Scall (None, f, res_e :: args)
99 let make_call_wo_struct tmpe res_type f_var args args_types =
100 let f_type = Clight.Tfunction (args_types, res_type) in
101 let f = Clight.Expr (f_var, f_type) in
102 Clight.Scall (Some tmpe, f, args)
104 let make_call type_substitutions tmp f_id args_with_types res_type =
105 let tmpe = Clight.Expr (Clight.Evar tmp, res_type) in
106 let args_with_types =
107 address_if_subst_complex type_substitutions args_with_types in
108 let (args, args_types) = List.split args_with_types in
109 let f_var = Clight.Evar f_id in
111 if is_subst_complex type_substitutions res_type then make_call_struct
112 else make_call_wo_struct in
113 (tmpe, call tmpe res_type f_var args args_types)
115 let call fresh replaced type_substitutions replacement_assoc
116 args added_stmt added_tmps ret_type =
117 let tmp = fresh () in
118 let replacement_fun_name = List.assoc replaced replacement_assoc in
120 make_call type_substitutions tmp replacement_fun_name args ret_type in
121 let stmt = seq (added_stmt @ [call]) in
122 (tmpe, stmt, added_tmps @ [(tmp, ret_type)])
124 let replace_ident replacement_assoc x t =
125 let new_name = match t with
127 when List.mem_assoc (Runtime.Fun x) replacement_assoc ->
128 let replacement_fun_name = List.assoc (Runtime.Fun x) replacement_assoc in
131 (Clight.Expr (Clight.Evar new_name, t), Clight.Sskip, [])
133 let replace_expression fresh type_substitutions replacement_assoc e =
135 let rec aux (Clight.Expr (ed, t) as e) =
136 let expr ed = Clight.Expr (ed, t) in
139 | Clight.Econst_int _ | Clight.Econst_float _ | Clight.Esizeof _ ->
140 (e, Clight.Sskip, [])
142 | Clight.Evar x -> replace_ident replacement_assoc x t
144 | Clight.Ederef e' ->
145 let (e', stmt, tmps) = aux e' in
146 (expr (Clight.Ederef e'), stmt, tmps)
148 | Clight.Eaddrof e' ->
149 let (e', stmt, tmps) = aux e' in
150 (expr (Clight.Eaddrof e'), stmt, tmps)
152 | Clight.Eunop (unop, (Clight.Expr (ed', t') as e'))
153 when List.mem_assoc (Runtime.Unary (unop, t')) replacement_assoc ->
154 let (e', stmt, tmps) = aux e' in
155 call fresh (Runtime.Unary (unop, t'))
156 type_substitutions replacement_assoc [(e', t')]
159 | Clight.Eunop (unop, e') ->
160 let (e', stmt, tmps) = aux e' in
161 (expr (Clight.Eunop (unop, e')), stmt, tmps)
163 | Clight.Ebinop (binop,
164 (Clight.Expr (ed1, t1) as e1),
165 (Clight.Expr (ed2, t2) as e2))
167 List.mem_assoc (Runtime.Binary (binop, t1, t2)) replacement_assoc ->
168 let (e1, stmt1, tmps1) = aux e1 in
169 let (e2, stmt2, tmps2) = aux e2 in
170 call fresh (Runtime.Binary (binop, t1, t2))
171 type_substitutions replacement_assoc
172 [(e1, t1) ; (e2, t2)] [stmt1 ; stmt2] (tmps1 @ tmps2) t
174 | Clight.Ebinop (binop, e1, e2) ->
175 let (e1, stmt1, tmps1) = aux e1 in
176 let (e2, stmt2, tmps2) = aux e2 in
177 let stmt = seq [stmt1 ; stmt2] in
178 (expr (Clight.Ebinop (binop, e1, e2)), stmt, tmps1 @ tmps2)
180 | Clight.Ecast (t, (Clight.Expr (_, t') as e'))
181 when List.mem_assoc (Runtime.Cast (t, t')) replacement_assoc ->
182 let (e', stmt, tmps) = aux e' in
183 call fresh (Runtime.Cast (t, t'))
184 type_substitutions replacement_assoc [(e', t')] [stmt]
187 | Clight.Ecast (t', e') ->
188 let (e', stmt, tmps) = aux e' in
189 (expr (Clight.Ecast (t', e')), stmt, tmps)
191 | Clight.Econdition (e1, e2, e3) ->
192 let (e1, stmt1, tmps1) = aux e1 in
193 let (e2, stmt2, tmps2) = aux e2 in
194 let (e3, stmt3, tmps3) = aux e3 in
195 let stmt = seq [stmt1 ; stmt2 ; stmt3] in
196 (expr (Clight.Econdition (e1, e2, e3)), stmt, tmps1 @ tmps2 @ tmps3)
198 | Clight.Eandbool (e1, e2) ->
199 let (e1, stmt1, tmps1) = aux e1 in
200 let (e2, stmt2, tmps2) = aux e2 in
201 let stmt = seq [stmt1 ; stmt2] in
202 (expr (Clight.Eandbool (e1, e2)), stmt, tmps1 @ tmps2)
204 | Clight.Eorbool (e1, e2) ->
205 let (e1, stmt1, tmps1) = aux e1 in
206 let (e2, stmt2, tmps2) = aux e2 in
207 let stmt = seq [stmt1 ; stmt2] in
208 (expr (Clight.Eorbool (e1, e2)), stmt, tmps1 @ tmps2)
210 | Clight.Efield (e', field) ->
211 let (e', stmt, tmps) = aux e' in
212 (expr (Clight.Efield (e', field)), stmt, tmps)
214 | Clight.Ecost (lbl, e') ->
215 let (e', stmt, tmps) = aux e' in
216 (expr (Clight.Ecost (lbl, e')), stmt, tmps)
218 | Clight.Ecall (id, e1, e2) ->
219 let (e1, stmt1, tmps1) = aux e1 in
220 let (e2, stmt2, tmps2) = aux e2 in
221 let stmt = seq [stmt1 ; stmt2] in
222 (expr (Clight.Ecall (id, e1, e2)), stmt, tmps1 @ tmps2)
228 let replace_expression_list fresh type_substitutions replacement_assoc =
229 let f (l, stmt, tmps) e =
230 let (e', stmt', tmps') =
231 replace_expression fresh type_substitutions replacement_assoc e in
232 (l @ [e'], seq [stmt ; stmt'], tmps @ tmps') in
233 List.fold_left f ([], Clight.Sskip, [])
236 let replace_statement fresh type_substitutions replacement_assoc =
238 replace_expression fresh type_substitutions replacement_assoc in
240 replace_expression_list fresh type_substitutions replacement_assoc in
242 let rec aux = function
244 | Clight.Sskip | Clight.Sbreak | Clight.Scontinue | Clight.Sgoto _
245 | Clight.Sreturn None
246 as stmt -> (stmt, [])
248 | Clight.Slabel (lbl, stmt) ->
249 let (stmt', tmps) = aux stmt in
250 (Clight.Slabel (lbl, stmt'), tmps)
252 | Clight.Scost (lbl, stmt) ->
253 let (stmt', tmps) = aux stmt in
254 (Clight.Scost (lbl, stmt'), tmps)
256 | Clight.Sassign (e1, e2) ->
257 let (e1', stmt1, tmps1) = aux_exp e1 in
258 let (e2', stmt2, tmps2) = aux_exp e2 in
259 let stmt = seq [stmt1 ; stmt2 ; Clight.Sassign (e1', e2')] in
260 (stmt, tmps1 @ tmps2)
262 | Clight.Scall (None, f, args) ->
263 let (f', stmt1, tmps1) = aux_exp f in
264 let (args', stmt2, tmps2) = aux_exp_list args in
265 let stmt = seq [stmt1 ; stmt2 ; Clight.Scall (None, f', args')] in
266 (stmt, tmps1 @ tmps2)
268 | Clight.Scall (Some e, f, args) ->
269 let (e', stmt1, tmps1) = aux_exp e in
270 let (f', stmt2, tmps2) = aux_exp f in
271 let (args', stmt3, tmps3) = aux_exp_list args in
272 let stmt = seq [stmt1 ; stmt2 ; stmt3 ;
273 Clight.Scall (Some e', f', args')] in
274 (stmt, tmps1 @ tmps2 @ tmps3)
276 | Clight.Sifthenelse (e, stmt1, stmt2) ->
277 let (e', stmte, tmpse) = aux_exp e in
278 let (stmt1', tmps1) = aux stmt1 in
279 let (stmt2', tmps2) = aux stmt2 in
280 let stmt = seq [stmte ; Clight.Sifthenelse (e', stmt1', stmt2')] in
281 (stmt, tmpse @ tmps1 @ tmps2)
283 | Clight.Swhile (e, stmt) ->
284 let (e', stmte, tmpse) = aux_exp e in
285 let (stmt', tmps) = aux stmt in
286 let stmt = seq [stmte ; Clight.Swhile (e', seq [stmt' ; stmte])] in
289 | Clight.Sdowhile (e, stmt) ->
290 let (e', stmte, tmpse) = aux_exp e in
291 let (stmt', tmps) = aux stmt in
292 let stmt = seq [Clight.Sdowhile (e', seq [stmt' ; stmte])] in
295 | Clight.Sfor (stmt1, e, stmt2, stmt3) ->
296 let (e', stmte, tmpse) = aux_exp e in
297 let (stmt1', tmps1) = aux stmt1 in
298 let (stmt2', tmps2) = aux stmt2 in
299 let (stmt3', tmps3) = aux stmt3 in
300 let stmt = seq [stmt1' ; stmte ;
301 Clight.Swhile (e', seq [stmt3' ; stmt2' ; stmte])] in
302 (stmt, tmpse @ tmps1 @ tmps2 @ tmps3)
304 | Clight.Sswitch (e, lbl_stmts) ->
305 let (e', stmte, tmpse) = aux_exp e in
306 let (lbl_stmts', tmps) = aux_lbl_stmts lbl_stmts in
307 let stmt = seq [stmte ; Clight.Sswitch (e', lbl_stmts')] in
310 | Clight.Sreturn (Some e) ->
311 let (e', stmte, tmpse) = aux_exp e in
312 let stmt = seq [stmte ; Clight.Sreturn (Some e')] in
315 | Clight.Ssequence (stmt1, stmt2) ->
316 let (stmt1', tmps1) = aux stmt1 in
317 let (stmt2', tmps2) = aux stmt2 in
318 let stmt = seq [stmt1' ; stmt2'] in
319 (stmt, tmps1 @ tmps2)
321 and aux_lbl_stmts = function
323 | Clight.LSdefault stmt ->
324 let (stmt', tmps) = aux stmt in
325 (Clight.LSdefault stmt', tmps)
327 | Clight.LScase (i, stmt, lbl_stmts) ->
328 let (stmt', tmps1) = aux stmt in
329 let (lbl_stmts', tmps2) = aux_lbl_stmts lbl_stmts in
330 (Clight.LScase (i, stmt', lbl_stmts'), tmps1 @ tmps2)
337 let f_ctype type_substitutions ctype sub_ctypes_res = match ctype with
338 | _ when List.mem_assoc ctype type_substitutions ->
339 List.assoc ctype type_substitutions
340 | _ -> ClightFold.ctype_fill_subs ctype sub_ctypes_res
342 let replace_ctype type_substitutions =
343 ClightFold.ctype (f_ctype type_substitutions)
345 let f_expr = ClightFold.expr_fill_subs
347 let f_expr_descr = ClightFold.expr_descr_fill_subs
349 let f_stmt = ClightFold.statement_fill_subs
351 let statement_replace_ctype type_substitutions =
352 ClightFold.statement (f_ctype type_substitutions) f_expr f_expr_descr f_stmt
355 let replace_internal fresh type_substitutions replacement_assoc def =
356 let (new_body, tmps) =
357 replace_statement fresh type_substitutions replacement_assoc
358 def.Clight.fn_body in
359 let new_body = statement_replace_ctype type_substitutions new_body in
360 let f (x, t) = (x, replace_ctype type_substitutions t) in
361 let params = List.map f def.Clight.fn_params in
362 let vars = List.map f (def.Clight.fn_vars @ tmps) in
363 { Clight.fn_return = replace_ctype type_substitutions def.Clight.fn_return ;
364 Clight.fn_params = params ;
365 Clight.fn_vars = vars ;
366 Clight.fn_body = new_body }
368 let replace_funct fresh type_substitutions replacement_assoc (id, fundef) =
369 let fundef' = match fundef with
370 | Clight.Internal def ->
372 (replace_internal fresh type_substitutions replacement_assoc def)
376 let replace fresh type_substitutions replacement_assoc p =
378 List.map (replace_funct fresh type_substitutions replacement_assoc)
379 p.Clight.prog_funct in
380 { p with Clight.prog_funct = prog_funct }
383 (* The constant replacement replaces each 32 bits and 16 bits integer constant
384 by a global variable of the same value. They will be replaced by the
385 appropriate structural value by the global replacement that comes
391 type t = (int * Clight.intsize * Clight.ctype)
392 let compare = Pervasives.compare
395 let f_subs fresh replace subs map =
397 let (x, map) = replace fresh map x in
399 List.fold_left f ([], map) subs
401 let rec replace_constant_expr fresh map (Clight.Expr (ed, t) as e) =
403 | Clight.Econst_int i, Clight.Tint (Clight.I8, _) ->
405 | Clight.Econst_int i, Clight.Tint (size, _)
406 when CstMap.mem (i, size, t) map ->
407 let id = CstMap.find (i, size, t) map in
408 (Clight.Expr (Clight.Evar id, t), map)
409 | Clight.Econst_int i, Clight.Tint (size, _) ->
411 let map = CstMap.add (i, size, t) id map in
412 let id = CstMap.find (i, size, t) map in
413 (Clight.Expr (Clight.Evar id, t), map)
415 let (sub_ctypes, sub_exprs) = ClightFold.expr_descr_subs ed in
416 let (sub_exprs, map) = f_subs fresh replace_constant_expr sub_exprs map in
417 let ed = ClightFold.expr_descr_fill_subs ed sub_ctypes sub_exprs in
418 (Clight.Expr (ed, t), map)
420 let rec replace_constant_stmt fresh map stmt =
421 let (sub_exprs, sub_stmts) = ClightFold.statement_subs stmt in
422 let (sub_exprs, map) =
423 f_subs fresh replace_constant_expr sub_exprs map in
424 let (sub_stmts, map) =
425 f_subs fresh replace_constant_stmt sub_stmts map in
426 (ClightFold.statement_fill_subs stmt sub_exprs sub_stmts, map)
428 let replace_constant_fundef fresh (functs, map) (id, fundef) =
430 | Clight.Internal cfun ->
431 let (body, map) = replace_constant_stmt fresh map cfun.Clight.fn_body in
432 let fundef = Clight.Internal { cfun with Clight.fn_body = body } in
433 (functs @ [(id, fundef)], map)
434 | Clight.External _ -> (functs @ [(id, fundef)], map)
436 let init_datas i size =
438 | Clight.I8 -> Clight.Init_int8 i
439 | Clight.I16 -> Clight.Init_int16 i
440 | Clight.I32 -> Clight.Init_int32 i]
442 let globals_of_map map =
443 let f (i, size, t) id l = l @ [((id, init_datas i size), t)] in
446 let replace_constant p =
447 let tmp_universe = ClightAnnotator.fresh_universe "_cst" p in
448 let fresh () = StringTools.Gen.fresh tmp_universe in
450 List.fold_left (replace_constant_fundef fresh)
451 ([], CstMap.empty) p.Clight.prog_funct in
452 let csts = globals_of_map map in
454 Clight.prog_funct = functs ; Clight.prog_vars = p.Clight.prog_vars @ csts }
457 (* Globals replacement *)
459 let expand_int size i =
460 let i = Big_int.big_int_of_int i in
462 if Big_int.ge_big_int i Big_int.zero_big_int then i
463 else Big_int.add_big_int i (Big_int.power_int_positive_int 2 size) in
464 let bound = Big_int.power_int_positive_int 2 8 in
468 let (next, chunk) = Big_int.quomod_big_int i bound in
469 chunk :: (aux (n+1) next) in
470 List.map (fun i -> Clight.Init_int8 (Big_int.int_of_big_int i)) (aux 0 i)
472 let expand_init_data = function
473 | Clight.Init_int16 i -> expand_int 2 i
474 | Clight.Init_int32 i -> expand_int 4 i
475 | init_data -> [init_data]
477 let expand_init_datas init_datas =
478 List.flatten (List.map expand_init_data init_datas)
480 let replace_global type_substitutions ((id, init_datas), t) =
481 let init_datas = expand_init_datas init_datas in
482 ((id, init_datas), replace_ctype type_substitutions t)
484 let replace_globals type_substitutions p =
485 let vars = List.map (replace_global type_substitutions) p.Clight.prog_vars in
486 { p with Clight.prog_vars = vars }
489 (* Unsupported operations by the 8051. *)
491 (* 8 bits signed division *)
494 "signed char " ^ s ^ " (signed char x, signed char y) {\n" ^
495 " unsigned char x1 = (unsigned char) x;\n" ^
496 " unsigned char y1 = (unsigned char) y;\n" ^
497 " signed char sign = 1;\n" ^
498 " if (x < 0) { x1 = (unsigned char) (-x); sign = -sign; }\n" ^
499 " if (y < 0) { y1 = (unsigned char) (-y); sign = -sign; }\n" ^
500 " return (sign * ((signed char) (x1/y1)));\n" ^
504 (Runtime.Binary (Clight.Odiv, cint8s, cint8s), "_divs", [], divs_fun, [])
507 (* 8 bits signed modulo *)
510 "signed char " ^ s ^ " (signed char x, signed char y) {\n" ^
511 " return (x - (x/y) * y);\n" ^
515 (Runtime.Binary (Clight.Omod, cint8s, cint8s), "_mods", [], mods_fun,
516 [Runtime.Binary (Clight.Odiv, cint8s, cint8s)])
521 let sh_fun signedness op s _ =
522 signedness ^ " char " ^ s ^ " (" ^ signedness ^ " char x, " ^
523 signedness ^ " char y) {\n" ^
524 " " ^ signedness ^ " char res = x, i;\n" ^
525 " for (i = 0 ; i < y ; i++) res = res " ^ op ^ " 2;\n" ^
529 (* 8 bits shifts left *)
531 let shls_fun = sh_fun "signed" "*"
534 (Runtime.Binary (Clight.Oshl, cint8s, cint8s), "_shls", [], shls_fun, [])
537 "unsigned char " ^ s ^ " (unsigned char x, unsigned char y) {\n" ^
538 " return ((unsigned char) ((signed char) x << (signed char) y));\n" ^
542 (Runtime.Binary (Clight.Oshl, cint8u, cint8u), "_shlu", [], shlu_fun,
543 [Runtime.Binary (Clight.Oshl, cint8s, cint8s)])
545 (* 8 bits shifts right *)
548 "signed char " ^ s ^ " (signed char x, signed char y) {\n" ^
549 " signed char res = x, i;\n" ^
550 " for (i = 0 ; i < y ; i++) {\n" ^
551 " res = ((unsigned char) res) / 2;\n" ^
552 " res = res + ((signed char) 128);\n" ^
558 (Runtime.Binary (Clight.Oshr, cint8s, cint8s), "_shrs", [], shrs_fun, [])
560 let shru_fun = sh_fun "unsigned" "/"
563 (Runtime.Binary (Clight.Oshr, cint8u, cint8u), "_shru", [], shru_fun, [])
568 let struct_int32 name fields = match fields with
569 | lolo :: lohi :: hilo :: hihi :: _ ->
572 [(lolo, cint8u) ; (lohi, cint8u) ; (hilo, cint8u) ; (hihi, cint8u)])
573 | _ -> error ("bad field names when defining type " ^ name ^ ".")
575 let struct_int32_name = "struct _int32_"
577 let new_int32 int32 =
582 (int32, struct_int32_name, [lolo ; lohi ; hilo ; hihi], struct_int32)
584 let int32s = new_int32 (Clight.Tint (Clight.I32, AST.Signed))
585 let int32u = new_int32 (Clight.Tint (Clight.I32, AST.Unsigned))
587 (* 32 bits operations *)
589 (* 32 bits equality *)
591 let eq_int32s_fun s l =
592 let (int32, lolo, lohi, hilo, hihi) = match l with
593 | (int32, lolo :: lohi :: hilo :: hihi :: _) :: _ ->
594 (int32, lolo, lohi, hilo, hihi)
595 | _ -> error ("new type definition not coherent in function " ^ s ^ ".") in
596 int32 ^ " " ^ s ^ " (" ^ int32 ^ " x, " ^ int32 ^ " y) {\n" ^
597 " " ^ int32 ^ " res;\n" ^
598 " res." ^ lolo ^ " = 1;\n" ^
599 " if (x." ^ lolo ^ " != y." ^ lolo ^ ") res." ^ lolo ^ " = 0;\n" ^
600 " if (x." ^ lohi ^ " != y." ^ lohi ^ ") res." ^ lolo ^ " = 0;\n" ^
601 " if (x." ^ hilo ^ " != y." ^ hilo ^ ") res." ^ lolo ^ " = 0;\n" ^
602 " if (x." ^ hihi ^ " != y." ^ hihi ^ ") res." ^ lolo ^ " = 0;\n" ^
603 " res." ^ lohi ^ " = 0;\n" ^
604 " res." ^ hilo ^ " = 0;\n" ^
605 " res." ^ hihi ^ " = 0;\n" ^
610 (Runtime.Binary (Clight.Oeq, cint32s, cint32s), "eq_int32s",
611 [struct_int32_name], eq_int32s_fun, [])
615 let int32s_to_int8s_fun s l =
616 let (int32, lolo, lohi, hilo, hihi) = match l with
617 | (int32, lolo :: lohi :: hilo :: hihi :: _) :: _ ->
618 (int32, lolo, lohi, hilo, hihi)
619 | _ -> error ("new type definition not coherent in function " ^ s ^ ".") in
620 "signed char " ^ s ^ " (" ^ int32 ^ " x) {\n" ^
621 " return ((signed char) x." ^ lolo ^ ");\n" ^
624 let int32s_to_int8s =
625 (Runtime.Cast (cint8s, cint32s), "int32s_to_int8s", [struct_int32_name],
626 int32s_to_int8s_fun, [])
631 let struct_int16 name fields = match fields with
633 Clight.Tstruct (name, [(lo, cint8u) ; (hi, cint8u)])
634 | _ -> error ("bad field names when defining type " ^ name ^ ".")
636 let struct_int16_name = "struct _int16_"
638 let new_int16 int16 =
641 (int16, struct_int16_name, [lo ; hi], struct_int16)
643 let int16s = new_int16 (Clight.Tint (Clight.I16, AST.Signed))
644 let int16u = new_int16 (Clight.Tint (Clight.I16, AST.Unsigned))
647 (* int32 and int16 *)
649 let int32_and_int16_types = [int32s ; int32u ; int16s ; int16u]
650 let int32_and_int16_replacements = [eq32s ; int32s_to_int8s]
652 let unsupported = [divs ; mods ; shls ; shlu ; shrs ; shru]
654 let save_and_parse p =
655 ClightParser.process (`Source ("32to8", ClightPrinter.print_program p))
657 let add_replacements p new_types replacements =
658 let p = ClightCasts.simplify p in
659 let (p, type_substitutions, replacement_assoc) =
660 Runtime.add p new_types replacements in
661 let p = ClightCasts.simplify p in
662 let tmp_universe = ClightAnnotator.fresh_universe "_tmp" p in
663 let fresh () = StringTools.Gen.fresh tmp_universe in
664 let p = replace fresh type_substitutions replacement_assoc p in
665 let p = replace_globals type_substitutions p in
666 (* Printf.printf "%s\n%!" (ClightPrinter.print_program p) ; *)
667 let p = save_and_parse p in
668 ClightCasts.simplify p
671 let p = main_returns_char p in
672 let p = replace_constant p in
674 add_replacements p int32_and_int16_types int32_and_int16_replacements in
675 add_replacements p [] unsupported