CristalCaveGem » LustreC

open Lustre_types

open Corelang

open Machine_code_types

let print_version fmt =

  | Cst c         -> pp_c_const fmt c

  | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " pp_c_val) vl

  | Access (t, i) -> fprintf fmt "%a[%a]" pp_c_val t pp_c_val i

  | Var v    ->

       (* array memory vars are represented by an indirection to a local var with the right type,

          in order to avoid casting everywhere. *)

       if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr)

  (* mpfr_t is a static array, not treated as general arrays *)

  if Types.is_address_type id.var_type

  then

    then fprintf fmt "(*%s)" id.var_id

    else fprintf fmt "%s" id.var_id

  else

    then fprintf fmt "*%s" id.var_id

    else fprintf fmt "%s" id.var_id

  then

    fprintf fmt "%s" id.var_id

  else

    then

      fprintf fmt "%s" id.var_id

    else

  then

    Format.fprintf fmt "%a = %a"

      (pp_c_type  ~var_opt:(Some id) id.var_id) id.var_type

  else

    Format.fprintf fmt "%a"

      (pp_c_type  ~var_opt:(Some id) id.var_id) id.var_type

    ()

let print_machine_struct machines fmt m =

    begin

    end

  else

    fprintf fmt "&%s" id.var_id

let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =

  then

    fprintf fmt "%a (%a%t%a);"

      pp_machine_step_name mname

      self

let pp_c_var m self pp_var fmt var =

let pp_array_suffix fmt loop_vars =

    end

let pp_const_initialize m pp_var fmt const =

  let rec aux indices value fmt typ =

    if Types.is_array_type typ

    then

    end

let pp_const_clear pp_var fmt const =

  let var = Corelang.var_decl_of_const const in

  let rec aux indices fmt typ =

    if Types.is_array_type typ

  var_loops @ int_loops

(* Prints a one loop variable suffix for arrays *)

 match snd lv with

 | LVar v -> fprintf fmt "[%s]" v

 | LInt r -> fprintf fmt "[%d]" !r

(* Prints a suffix of loop variables for arrays *)

(* Prints a value expression [v], with internal function calls only.

   [pp_var] is a printer for variables (typically [pp_c_var_read]),

(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)

  (*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)

  (

    match loop_vars, value.value_desc with

    | (x, LAcc i) :: q, _ when is_const_index i ->

       let r = ref (Dimension.size_const_dimension (dimension_of_value i)) in

    | (_, LInt r) :: q, Cst (Const_array cl) ->

       let var_type = Types.array_element_type var_type in

    | (_, LInt r) :: q, Array vl      ->

       let var_type = Types.array_element_type var_type in

    | loop_var    :: q, Array vl      ->

       let var_type = Types.array_element_type var_type in

    | []              , Array vl      ->

       let var_type = Types.array_element_type var_type in

    | _           :: q, Power (v, n)  ->

    | _               , Fun (n, vl)   ->

    | _               , Access (v, i) ->

       let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in

    | _               , Var v    ->

       if is_memory m v then (

         (* array memory vars are represented by an indirection to a local var with the right type,

	    in order to avoid casting everywhere. *)

         if Types.is_array_type v.var_type

       )

       else (

       )

    | _               , Cst cst       -> pp_c_const_suffix var_type fmt cst

    | _               , _             -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type (pp_val m) value pp_suffix loop_vars; assert false)

            let stmts = in_assigns :: out_assigns :: imp_nd.node_stmts @ stmts in

            let c = merge_contracts c imp_c in

            stmts, locals, c 

        ) ([], c.consts@c.locals, c) c.imports

(* Conversion from dimension expr to standard expr, for the purpose of printing, typing, etc... *)

let rec expr_of_dimension dim =

  let open Dimension in

  match dim.dim_desc with

 | Dbool b        ->

     mkexpr dim.dim_loc (Expr_const (const_of_bool b))

 | Dvar

 | Dunivar          -> (Format.eprintf "internal error: Corelang.expr_of_dimension %a@." Dimension.pp_dimension dim;

			assert false)

let dimension_of_const loc const =

  let open Dimension in

 match const with

        let typ = (typedef_of_top (Hashtbl.find Corelang.tag_table id)).tydef_id in

        mk_val (Cst (Const_tag id)) (Type_predef.type_const typ)

      with Not_found -> (Format.eprintf

                           id;

                         assert false)

   expr_tag = Utils.new_tag ();

   expr_desc = Expr_tuple (List.map expr_of_vdecl locals) }

(* IS IT USED ? TODO 

(* Create an alias for [expr], if none exists yet *)

let mk_expr_alias (parentid, vars) (defs, vars) expr =

 *)

(* Create an alias for [expr], if [expr] is not already an alias (i.e. an ident)

let mk_expr_alias_opt opt norm_ctx (defs, vars) expr =

  if !debug then

    Log.report ~plugin:"normalization" ~level:2

      else

	(defs, vars), expr

(* Create a (normalized) expression from [ref_e],

   replacing description with [norm_d],

   taking propagated [offsets] into account

    ) elist (defvars, [])

let rec normalize_expr ?(alias=true) ?(alias_basic=false) norm_ctx offsets defvars expr =

  match expr.expr_desc with

  | Expr_const _

  | Expr_array elist ->

     let defvars, norm_elist = normalize_list alias norm_ctx offsets (fun _ -> normalize_array_expr ~alias:true) defvars elist in

     let norm_expr = mk_norm_expr offsets expr (Expr_array norm_elist) in

  | Expr_power (e1, d) ->

     normalize_expr ~alias:alias norm_ctx (List.tl offsets) defvars e1

  | Expr_access (e1, d) ->

  | Expr_tuple elist ->

     let defvars, norm_elist =

       normalize_list alias norm_ctx offsets (fun alias -> normalize_expr ~alias:alias ~alias_basic:false) defvars elist in

     defvars, mk_norm_expr offsets expr (Expr_tuple norm_elist)

  | Expr_appl (id, args, None)

      when Basic_library.is_homomorphic_fun id 

     let defvars, norm_args =

       normalize_list

	 alias

  |  _ -> normalize_expr ~alias:alias norm_ctx offsets defvars expr

and normalize_cond_expr ?(alias=true) norm_ctx offsets defvars expr =

  match expr.expr_desc with

  | Expr_access (e1, d) ->

     normalize_cond_expr ~alias:alias norm_ctx (d::offsets) defvars e1