heptagon/compiler/obc/c/async_avr.ml

open Names
open Types
open C
open Obc
open Async
open Async_backend

module AvrBackend : AsyncBackend =
struct
  type clock =
    | Timer_ms of int

  (* FIXME(Arduino): don't do a shallow copy *)
  let gen_copy_func cd suffix =
    let func_name = (cname_of_qn cd.cd_name) ^ "_copy" ^ suffix in
    (* TODO(Arduino): add const qualifier *)
    let arg_ty = Cty_ptr (Cty_id (qn_append cd.cd_name suffix)) in
    let sizeof = Cfun_call ("sizeof", [Cderef (Cvar "src")]) in
    let memcpy =
      Cfun_call ("atomic_memcpy", [Cvar "dest"; Cvar "src"; sizeof])
    in
    Cfundef {
      C.f_name = func_name;
      f_retty = Cty_void;
      f_args = [("dest", arg_ty); ("src", arg_ty)];
      f_body = {
       var_decls = [];
       block_body = [Csexpr memcpy] }
    }

  let gen_copy_func_in cd = gen_copy_func cd "_in"

  let gen_copy_func_out cd = gen_copy_func cd "_out"

  let includes = ["avr"]

  let translate_ack { ack_name = name; ack_params = params } =
    match params with
      | [{se_desc = Sint ms}] when name = "timer_ms" -> Timer_ms ms
      | _ -> assert false

  let rec gcd a = function
    | 0 -> abs a
    | b -> gcd b (a mod b)

  let lcm a b = match a, b with
    | 0, _ | _, 0 -> 0
    | _ -> abs (a * b) / (gcd a b)

  let fold_lcm l = List.fold_left lcm (List.hd l) (List.tl l)

  let fold_gcd l = List.fold_left gcd (List.hd l) (List.tl l)

  let ms_of_ack = function
    | Timer_ms ms -> ms

  let incr_mod name modulo =
    let one_const = Cconst (Ccint 1) in
    let modulo_const = Cconst (Ccint modulo) in
    let incr = Cbop ("+", Cvar name, one_const) in
    Caffect (CLvar name, Cbop ("%", incr, modulo_const))

  let call_step_async tick_var base (od, ack) =
    let step = (cname_of_qn od.o_class) ^ "_async_step" in
    let global = async_global_var_name od in
    let call = Csexpr (Cfun_call (step, [Caddrof (Cvar global)])) in
    let zero = Cconst (Ccint 0) in
    let timer = Cconst (Ccint (ms_of_ack ack / base)) in
    let cond = Cbop ("==", Cbop ("%", tick_var, timer), zero) in
    Cif (cond, [call], [])

  let translate_objs objs =
    List.map
      (fun od ->
        let ack = Option.get od.o_ack in
        (od, translate_ack ack))
      objs

  let decls_and_defs objs =
    let trans = translate_objs objs in
    let timers = List.map
      (fun (_, ack) -> ms_of_ack ack)
      trans
    in
    let body = match timers with
      | [] -> []
      | _ ->
         let gcd_timer = fold_gcd timers in
         let lcm_timer = fold_lcm timers in
         let steps =
           List.map (call_step_async (Cvar "tick") gcd_timer) trans
         in
         let incr = incr_mod "tick" (lcm_timer / gcd_timer) in
         steps @ [incr]
    in
    (* run_timers is declared in avr.h (because of the ISR macro which
     * I don't know how to generate here) *)
    let defs = [
      Cfundef {
        C.f_name = "run_timers";
        f_retty = Cty_void;
        f_args = [];
        f_body = {
          var_decls = [
            mk_vardecl_val ~static:true "tick" Cty_int (Cconst (Ccint 0))
          ];
          block_body = body
        }
      }
    ] in
    [], defs

  let main_init objs =
    let trans = translate_objs objs in
    let timers = List.map
      (fun (_, ack) -> ms_of_ack ack)
      trans
    in
    match timers with
    | [] -> []
    | _ ->
      let value = fold_gcd timers in
      [Csexpr (Cfun_call ("init_timer1", [Cconst (Ccint value)]))]

end