source: Deliverables/D2.2/8051/src/clight/clight32ToClight8.ml @ 3673

Last change on this file since 3673 was 818, checked in by ayache, 9 years ago

32 and 16 bits operations support in D2.2/8051

File size: 22.6 KB
Line 
1
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
4    bits integers.
5
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. *)
12
13
14let error_prefix = "Clight32 to Clight8"
15let error s = Error.global_error error_prefix s
16
17
18let cint32s = Clight.Tint (Clight.I32, AST.Signed)
19let cint32u = Clight.Tint (Clight.I32, AST.Unsigned)
20let cint8s = Clight.Tint (Clight.I8, AST.Signed)
21let cint8u = Clight.Tint (Clight.I8, AST.Unsigned)
22
23
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. *)
27
28let 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."
32
33let f_ctype ctype _ = ctype
34let f_expr e _ _ = e
35let f_expr_descr ed _ _ = ed
36
37let 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
43
44let body_returns ret_type =
45  ClightFold.statement f_ctype f_expr f_expr_descr (f_stmt ret_type)
46
47let 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
54
55let main_returns_char p = match p.Clight.prog_main with
56  | None -> p
57  | Some main ->
58    let main_def = List.assoc main p.Clight.prog_funct in
59    let main_def = fundef_returns_char main_def in
60    let prog_funct =
61      MiscPottier.update_list_assoc main main_def p.Clight.prog_funct in
62    { p with Clight.prog_funct = prog_funct }
63
64
65(* Replacement *)
66
67let seq =
68  List.fold_left
69    (fun stmt1 stmt2 -> Clight.Ssequence (stmt1, stmt2))
70    Clight.Sskip
71
72let is_complex = function
73  | Clight.Tstruct _ | Clight.Tunion _ -> true
74  | _ -> false
75
76let 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)
79  else false
80
81let addrof_with_type e ctype =
82  let ctype = Clight.Tpointer ctype in
83  (Clight.Expr (Clight.Eaddrof e, ctype), ctype)
84
85let address_if_subst_complex type_substitutions =
86  let f l (e, ctype) =
87    let arg_and_type =
88      if is_subst_complex type_substitutions ctype then addrof_with_type e ctype
89      else (e, ctype) in
90    l @ [arg_and_type] in
91  List.fold_left f []
92
93let 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)
98
99let 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)
103
104let 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
110  let call =
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)
114
115let 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
119  let (tmpe, call) =
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)])
123
124let replace_ident replacement_assoc x t =
125  let new_name = match t with
126    | Clight.Tfunction _
127        when List.mem_assoc (Runtime.Fun x) replacement_assoc ->
128      let replacement_fun_name = List.assoc (Runtime.Fun x) replacement_assoc in
129      replacement_fun_name
130    | _ -> x in
131  (Clight.Expr (Clight.Evar new_name, t), Clight.Sskip, [])
132
133let replace_expression fresh type_substitutions replacement_assoc e =
134
135  let rec aux (Clight.Expr (ed, t) as e) =
136    let expr ed = Clight.Expr (ed, t) in
137    match ed with
138
139      | Clight.Econst_int _ | Clight.Econst_float _ | Clight.Esizeof _ ->
140        (e, Clight.Sskip, [])
141
142      | Clight.Evar x -> replace_ident replacement_assoc x t
143
144      | Clight.Ederef e' ->
145        let (e', stmt, tmps) = aux e' in
146        (expr (Clight.Ederef e'), stmt, tmps)
147
148      | Clight.Eaddrof e' ->
149        let (e', stmt, tmps) = aux e' in
150        (expr (Clight.Eaddrof e'), stmt, tmps)
151
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')]
157          [stmt] tmps t
158
159      | Clight.Eunop (unop, e') ->
160        let (e', stmt, tmps) = aux e' in
161        (expr (Clight.Eunop (unop, e')), stmt, tmps)
162
163      | Clight.Ebinop (binop,
164                       (Clight.Expr (ed1, t1) as e1),
165                       (Clight.Expr (ed2, t2) as e2))
166          when
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
173
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)
179
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]
185          tmps t
186
187      | Clight.Ecast (t', e') ->
188        let (e', stmt, tmps) = aux e' in
189        (expr (Clight.Ecast (t', e')), stmt, tmps)
190
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)
197
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)
203
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)
209
210      | Clight.Efield (e', field) ->
211        let (e', stmt, tmps) = aux e' in
212        (expr (Clight.Efield (e', field)), stmt, tmps)
213
214      | Clight.Ecost (lbl, e') ->
215        let (e', stmt, tmps) = aux e' in
216        (expr (Clight.Ecost (lbl, e')), stmt, tmps)
217
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)
223
224  in
225  aux e
226
227
228let 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, [])
234
235
236let replace_statement fresh type_substitutions replacement_assoc =
237  let aux_exp =
238    replace_expression fresh type_substitutions replacement_assoc in
239  let aux_exp_list =
240    replace_expression_list fresh type_substitutions replacement_assoc in
241
242  let rec aux = function
243
244    | Clight.Sskip | Clight.Sbreak | Clight.Scontinue | Clight.Sgoto _
245    | Clight.Sreturn None
246        as stmt -> (stmt, [])
247
248    | Clight.Slabel (lbl, stmt) ->
249      let (stmt', tmps) = aux stmt in
250      (Clight.Slabel (lbl, stmt'), tmps)
251
252    | Clight.Scost (lbl, stmt) ->
253      let (stmt', tmps) = aux stmt in
254      (Clight.Scost (lbl, stmt'), tmps)
255
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)
261
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)
267
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)
275
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)
282
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
287      (stmt, tmpse @ tmps)
288
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
293      (stmt, tmpse @ tmps)
294
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)
303
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
308      (stmt, tmpse @ tmps)
309
310    | Clight.Sreturn (Some e) ->
311      let (e', stmte, tmpse) = aux_exp e in
312      let stmt = seq [stmte ; Clight.Sreturn (Some e')] in
313      (stmt, tmpse)
314
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)
320
321  and aux_lbl_stmts = function
322
323    | Clight.LSdefault stmt ->
324      let (stmt', tmps) = aux stmt in
325      (Clight.LSdefault stmt', tmps)
326
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)
331
332  in
333
334  aux
335
336
337let 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
341
342let replace_ctype type_substitutions =
343  ClightFold.ctype (f_ctype type_substitutions)
344
345let f_expr = ClightFold.expr_fill_subs
346
347let f_expr_descr = ClightFold.expr_descr_fill_subs
348
349let f_stmt = ClightFold.statement_fill_subs
350
351let statement_replace_ctype type_substitutions =
352  ClightFold.statement (f_ctype type_substitutions) f_expr f_expr_descr f_stmt
353
354
355let 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 }
367
368let replace_funct fresh type_substitutions replacement_assoc (id, fundef) =
369  let fundef' = match fundef with
370    | Clight.Internal def ->
371      Clight.Internal
372        (replace_internal fresh type_substitutions replacement_assoc def)
373    | _ -> fundef in
374  (id, fundef')
375
376let replace fresh type_substitutions replacement_assoc p =
377  let prog_funct =
378    List.map (replace_funct fresh type_substitutions replacement_assoc)
379      p.Clight.prog_funct in
380  { p with Clight.prog_funct = prog_funct }
381
382
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
386   afterwards. *)
387
388module CstMap =
389  Map.Make
390    (struct
391      type t = (int * Clight.intsize * Clight.ctype)
392      let compare = Pervasives.compare
393     end)
394
395let f_subs fresh replace subs map =
396  let f (l, map) x =
397    let (x, map) = replace fresh map x in
398    (l @ [x], map) in
399  List.fold_left f ([], map) subs
400
401let rec replace_constant_expr fresh map (Clight.Expr (ed, t) as e) =
402  match ed, t with
403    | Clight.Econst_int i, Clight.Tint (Clight.I8, _) ->
404      (e, map)
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, _) ->
410      let id = fresh () in
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)
414    | _ ->
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)
419
420let 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)
427
428let replace_constant_fundef fresh (functs, map) (id, fundef) =
429  match fundef with
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)
435
436let init_datas i size =
437  [match size with
438    | Clight.I8 -> Clight.Init_int8 i
439    | Clight.I16 -> Clight.Init_int16 i
440    | Clight.I32 -> Clight.Init_int32 i]
441
442let globals_of_map map =
443  let f (i, size, t) id l = l @ [((id, init_datas i size), t)] in
444  CstMap.fold f map []
445
446let replace_constant p =
447  let tmp_universe = ClightAnnotator.fresh_universe "_cst" p in
448  let fresh () = StringTools.Gen.fresh tmp_universe in
449  let (functs, map) =
450    List.fold_left (replace_constant_fundef fresh)
451      ([], CstMap.empty) p.Clight.prog_funct in
452  let csts = globals_of_map map in
453  { p with
454    Clight.prog_funct = functs ; Clight.prog_vars = p.Clight.prog_vars @ csts }
455
456
457(* Globals replacement *)
458
459let expand_int size i =
460  let i = Big_int.big_int_of_int i in
461  let i =
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
465  let rec aux n i =
466    if n >= size then []
467    else
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)
471
472let 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]
476
477let expand_init_datas init_datas =
478  List.flatten (List.map expand_init_data init_datas)
479
480let 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)
483
484let 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 }
487
488
489(* Unsupported operations by the 8051. *)
490
491(* 8 bits signed division *)
492
493let divs_fun s _ =
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" ^
501  "}\n\n"
502
503let divs =
504  (Runtime.Binary (Clight.Odiv, cint8s, cint8s), "_divs", [], divs_fun, [])
505
506
507(* 8 bits signed modulo *)
508
509let mods_fun s _ =
510  "signed char " ^ s ^ " (signed char x, signed char y) {\n" ^
511  "  return (x - (x/y) * y);\n" ^
512  "}\n\n"
513
514let mods =
515  (Runtime.Binary (Clight.Omod, cint8s, cint8s), "_mods", [], mods_fun,
516   [Runtime.Binary (Clight.Odiv, cint8s, cint8s)])
517
518
519(* Shifts *)
520
521let 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" ^
526  "  return res;\n" ^
527  "}\n\n"
528
529(* 8 bits shifts left *)
530
531let shls_fun = sh_fun "signed" "*"
532
533let shls =
534  (Runtime.Binary (Clight.Oshl, cint8s, cint8s), "_shls", [], shls_fun, [])
535
536let shlu_fun s _ =
537  "unsigned char " ^ s ^ " (unsigned char x, unsigned char y) {\n" ^
538  "  return ((unsigned char) ((signed char) x << (signed char) y));\n" ^
539  "}\n\n"
540
541let shlu =
542  (Runtime.Binary (Clight.Oshl, cint8u, cint8u), "_shlu", [], shlu_fun,
543   [Runtime.Binary (Clight.Oshl, cint8s, cint8s)])
544
545(* 8 bits shifts right *)
546
547let shrs_fun s _ =
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" ^
553  "  }\n" ^
554  "  return res;\n" ^
555  "}\n\n"
556
557let shrs =
558  (Runtime.Binary (Clight.Oshr, cint8s, cint8s), "_shrs", [], shrs_fun, [])
559
560let shru_fun = sh_fun "unsigned" "/"
561
562let shru =
563  (Runtime.Binary (Clight.Oshr, cint8u, cint8u), "_shru", [], shru_fun, [])
564
565
566(* int32 *)
567
568let struct_int32 name fields = match fields with
569  | lolo :: lohi :: hilo :: hihi :: _ ->
570    Clight.Tstruct
571      (name,
572       [(lolo, cint8u) ; (lohi, cint8u) ; (hilo, cint8u) ; (hihi, cint8u)])
573  | _ -> error ("bad field names when defining type " ^ name ^ ".")
574
575let struct_int32_name = "struct _int32_"
576
577let new_int32 int32 =
578  let lolo = "lolo" in
579  let lohi = "lohi" in
580  let hilo = "hilo" in
581  let hihi = "hihi" in
582  (int32, struct_int32_name, [lolo ; lohi ; hilo ; hihi], struct_int32)
583
584let int32s = new_int32 (Clight.Tint (Clight.I32, AST.Signed))
585let int32u = new_int32 (Clight.Tint (Clight.I32, AST.Unsigned))
586
587(* 32 bits operations *)
588
589(* 32 bits equality *)
590
591let 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" ^
606  "  return (res);\n" ^
607  "}\n\n"
608
609let eq32s =
610  (Runtime.Binary (Clight.Oeq, cint32s, cint32s), "eq_int32s",
611   [struct_int32_name], eq_int32s_fun, [])
612
613(* 32 bits casts *)
614
615let 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" ^
622  "}\n\n"
623
624let int32s_to_int8s =
625  (Runtime.Cast (cint8s, cint32s), "int32s_to_int8s", [struct_int32_name],
626   int32s_to_int8s_fun, [])
627
628
629(* int16 *)
630
631let struct_int16 name fields = match fields with
632  | lo :: hi :: _ ->
633    Clight.Tstruct (name, [(lo, cint8u) ; (hi, cint8u)])
634  | _ -> error ("bad field names when defining type " ^ name ^ ".")
635
636let struct_int16_name = "struct _int16_"
637
638let new_int16 int16 =
639  let lo = "lo" in
640  let hi = "hi" in
641  (int16, struct_int16_name, [lo ; hi], struct_int16)
642
643let int16s = new_int16 (Clight.Tint (Clight.I16, AST.Signed))
644let int16u = new_int16 (Clight.Tint (Clight.I16, AST.Unsigned))
645
646
647(* int32 and int16 *)
648
649let int32_and_int16_types = [int32s ; int32u ; int16s ; int16u]
650let int32_and_int16_replacements = [eq32s ; int32s_to_int8s]
651
652
653let unsupported = [divs ; mods ; shls ; shlu ; shrs ; shru]
654
655
656let save_and_parse p =
657  let tmp_file = Filename.temp_file "clight32toclight8" ".c" in
658  try
659    let oc = open_out tmp_file in
660    output_string oc (ClightPrinter.print_program p) ;
661    close_out oc ;
662    let res = ClightParser.process tmp_file in
663    Misc.SysExt.safe_remove tmp_file ;
664    res
665  with Sys_error _ -> failwith "Error reparsing Clight8 transformation."
666
667let add_replacements p new_types replacements =
668  let p = ClightCasts.simplify p in
669  let (p, type_substitutions, replacement_assoc) =
670    Runtime.add p new_types replacements in
671  let p = ClightCasts.simplify p in
672  let tmp_universe = ClightAnnotator.fresh_universe "_tmp" p in
673  let fresh () = StringTools.Gen.fresh tmp_universe in
674  let p = replace fresh type_substitutions replacement_assoc p in
675  let p = replace_globals type_substitutions p in
676  (* Printf.printf "%s\n%!" (ClightPrinter.print_program p) ; *)
677  let p = save_and_parse p in
678  ClightCasts.simplify p
679
680let translate p =
681  let p = main_returns_char p in
682  let p = replace_constant p in
683  let p =
684    add_replacements p int32_and_int16_types int32_and_int16_replacements in
685  add_replacements p [] unsupported
Note: See TracBrowser for help on using the repository browser.