2012-06-27 18:09:30 +02:00
|
|
|
(***********************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon *)
|
|
|
|
(* *)
|
|
|
|
(* Gwenael Delaval, LIG/INRIA, UJF *)
|
|
|
|
(* Leonard Gerard, Parkas, ENS *)
|
|
|
|
(* Adrien Guatto, Parkas, ENS *)
|
|
|
|
(* Cedric Pasteur, Parkas, ENS *)
|
2012-06-29 01:43:15 +02:00
|
|
|
(* Marc Pouzet, Parkas, ENS *)
|
2012-06-27 18:09:30 +02:00
|
|
|
(* *)
|
|
|
|
(* Copyright 2012 ENS, INRIA, UJF *)
|
|
|
|
(* *)
|
|
|
|
(* This file is part of the Heptagon compiler. *)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon is free software: you can redistribute it and/or modify it *)
|
|
|
|
(* under the terms of the GNU General Public License as published by *)
|
|
|
|
(* the Free Software Foundation, either version 3 of the License, or *)
|
|
|
|
(* (at your option) any later version. *)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon is distributed in the hope that it will be useful, *)
|
|
|
|
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
|
|
|
|
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
|
|
|
|
(* GNU General Public License for more details. *)
|
|
|
|
(* *)
|
|
|
|
(* You should have received a copy of the GNU General Public License *)
|
|
|
|
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
|
|
|
|
(* *)
|
|
|
|
(***********************************************************************)
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
open List
|
|
|
|
open Misc
|
|
|
|
open Names
|
2010-07-23 19:45:19 +02:00
|
|
|
open Idents
|
2010-06-15 10:49:03 +02:00
|
|
|
open Obc
|
2011-03-08 09:22:02 +01:00
|
|
|
open Obc_utils
|
2010-07-09 09:31:12 +02:00
|
|
|
open Types
|
2010-07-27 16:27:07 +02:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
open Modules
|
2010-06-18 10:55:16 +02:00
|
|
|
open Signature
|
2010-06-15 10:49:03 +02:00
|
|
|
open C
|
|
|
|
open Location
|
2010-08-24 17:23:50 +02:00
|
|
|
open Format
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
module Error =
|
|
|
|
struct
|
|
|
|
type error =
|
|
|
|
| Evar of string
|
|
|
|
| Enode of string
|
|
|
|
| Eno_unnamed_output
|
2010-06-16 11:32:13 +02:00
|
|
|
| Ederef_not_pointer
|
2010-07-16 12:04:51 +02:00
|
|
|
| Estatic_exp_compute_failed
|
2010-09-13 13:32:35 +02:00
|
|
|
| Eunknown_method of string
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-27 17:24:31 +02:00
|
|
|
let message loc kind = (match kind with
|
|
|
|
| Evar name ->
|
2010-09-01 13:31:28 +02:00
|
|
|
eprintf "%aCode generation : The variable name '%s' is unbound.@."
|
2010-08-24 17:23:50 +02:00
|
|
|
print_location loc name
|
2010-06-27 17:24:31 +02:00
|
|
|
| Enode name ->
|
2010-09-01 13:31:28 +02:00
|
|
|
eprintf "%aCode generation : The node name '%s' is unbound.@."
|
2010-08-24 17:23:50 +02:00
|
|
|
print_location loc name
|
2010-06-27 17:24:31 +02:00
|
|
|
| Eno_unnamed_output ->
|
2010-09-01 13:31:28 +02:00
|
|
|
eprintf "%aCode generation : Unnamed outputs are not supported.@."
|
2010-08-24 17:23:50 +02:00
|
|
|
print_location loc
|
2010-06-27 17:24:31 +02:00
|
|
|
| Ederef_not_pointer ->
|
2010-09-01 13:31:28 +02:00
|
|
|
eprintf "%aCode generation : Trying to deference a non pointer type.@."
|
2010-08-24 17:23:50 +02:00
|
|
|
print_location loc
|
2010-07-16 12:04:51 +02:00
|
|
|
| Estatic_exp_compute_failed ->
|
|
|
|
eprintf "%aCode generation : Computation of the value of the static \
|
2010-09-01 13:31:28 +02:00
|
|
|
expression failed.@."
|
2010-09-13 13:32:35 +02:00
|
|
|
print_location loc
|
|
|
|
| Eunknown_method s ->
|
|
|
|
eprintf "%aCode generation : Methods other than step and \
|
|
|
|
reset are not supported (found '%s').@."
|
|
|
|
print_location loc
|
|
|
|
s);
|
2010-09-15 09:38:52 +02:00
|
|
|
raise Errors.Error
|
2010-06-15 10:49:03 +02:00
|
|
|
end
|
|
|
|
|
2013-03-15 09:31:19 +01:00
|
|
|
let struct_name ty =
|
2010-06-16 11:32:13 +02:00
|
|
|
match ty with
|
2010-06-27 17:24:31 +02:00
|
|
|
| Cty_id n -> n
|
|
|
|
| _ -> assert false
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-07-09 09:31:12 +02:00
|
|
|
let int_of_static_exp se =
|
2010-09-10 11:53:55 +02:00
|
|
|
Static.int_of_static_exp QualEnv.empty se
|
2010-07-09 09:31:12 +02:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
let output_names_list sig_info =
|
2010-06-15 10:49:03 +02:00
|
|
|
let remove_option ad = match ad.a_name with
|
2011-04-27 14:02:50 +02:00
|
|
|
| Some n -> n
|
2010-06-16 11:32:13 +02:00
|
|
|
| None -> Error.message no_location Error.Eno_unnamed_output
|
2010-06-15 10:49:03 +02:00
|
|
|
in
|
2011-05-10 14:01:54 +02:00
|
|
|
let outputs = List.filter
|
|
|
|
(fun ad -> not (Linearity.is_linear ad.a_linearity)) sig_info.node_outputs in
|
|
|
|
List.map remove_option outputs
|
2010-06-18 10:55:16 +02:00
|
|
|
|
2011-03-21 14:30:19 +01:00
|
|
|
let is_stateful n =
|
2010-06-30 17:30:24 +02:00
|
|
|
try
|
2010-09-10 11:53:55 +02:00
|
|
|
let sig_info = find_value n in
|
2011-03-21 14:30:19 +01:00
|
|
|
sig_info.node_stateful
|
2010-06-30 17:30:24 +02:00
|
|
|
with
|
|
|
|
Not_found -> Error.message no_location (Error.Enode (fullname n))
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(******************************)
|
|
|
|
|
|
|
|
(** {2 Translation from Obc to C using our AST.} *)
|
|
|
|
|
|
|
|
(** [ctype_of_type mods oty] translates the Obc type [oty] to a C
|
|
|
|
type. We assume that identified types have already been defined
|
|
|
|
before use. [mods] is an accumulator for modules to be opened for
|
2010-06-16 11:32:13 +02:00
|
|
|
each function (i.e., not opened by an "open" declaration).
|
2010-06-15 10:49:03 +02:00
|
|
|
We have to make a difference between function args and local vars
|
|
|
|
because of arrays (when used as args, we use a pointer).
|
|
|
|
*)
|
|
|
|
let rec ctype_of_otype oty =
|
|
|
|
match oty with
|
2010-07-09 09:31:12 +02:00
|
|
|
| Types.Tid id when id = Initial.pint -> Cty_int
|
|
|
|
| Types.Tid id when id = Initial.pfloat -> Cty_float
|
|
|
|
| Types.Tid id when id = Initial.pbool -> Cty_int
|
2010-09-13 15:16:12 +02:00
|
|
|
| Tid id -> Cty_id id
|
2011-03-21 14:30:19 +01:00
|
|
|
| Tarray(ty, n) -> Cty_arr(int_of_static_exp n, ctype_of_otype ty)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Tprod _ -> assert false
|
2011-04-14 18:06:54 +02:00
|
|
|
| Tinvalid -> assert false
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
let copname = function
|
|
|
|
| "=" -> "==" | "<>" -> "!=" | "&" -> "&&" | "or" -> "||" | "+" -> "+"
|
|
|
|
| "-" -> "-" | "*" -> "*" | "/" -> "/" | "*." -> "*" | "/." -> "/"
|
|
|
|
| "+." -> "+" | "-." -> "-" | "<" -> "<" | ">" -> ">" | "<=" -> "<="
|
2011-09-06 11:54:03 +02:00
|
|
|
| ">=" -> ">=" | "<=." -> "<=" | "<." -> "<" | ">=." -> ">=" | ">." -> ">"
|
2010-10-02 12:59:44 +02:00
|
|
|
| "~-" -> "-" | "not" -> "!" | "%" -> "%"
|
2011-12-06 17:46:35 +01:00
|
|
|
| ">>>" -> ">>" | "<<<" -> "<<" | "&&&" -> "&" | "|||" -> "|"
|
2010-06-15 10:49:03 +02:00
|
|
|
| op -> op
|
|
|
|
|
2011-11-22 14:43:52 +01:00
|
|
|
|
|
|
|
let cformat_of_format s =
|
|
|
|
let aux m = match m with
|
|
|
|
| "b" -> "d" (*no booleans in C*)
|
|
|
|
| _ -> m
|
|
|
|
in
|
|
|
|
match s with
|
|
|
|
| Cconst (Cstrlit s) -> Cconst (Cstrlit (Printf_parser.tr_format aux s))
|
|
|
|
| _ -> assert false
|
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Translates an Obc var_dec to a tuple (name, cty). *)
|
2010-06-15 10:49:03 +02:00
|
|
|
let cvar_of_vd vd =
|
2010-06-27 17:24:31 +02:00
|
|
|
name vd.v_ident, ctype_of_otype vd.v_type
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2011-09-09 13:54:29 +02:00
|
|
|
(** Returns the type of a pointer to a type, except for
|
|
|
|
types which are already pointers. *)
|
|
|
|
let pointer_type ty cty =
|
|
|
|
match Modules.unalias_type ty with
|
|
|
|
| Tarray _ -> cty
|
|
|
|
| _ -> Cty_ptr cty
|
|
|
|
|
|
|
|
(** Returns the expression to use e as an argument of
|
|
|
|
a function expecting a pointer as argument. *)
|
|
|
|
let address_of ty e =
|
|
|
|
match Modules.unalias_type ty with
|
|
|
|
| Tarray _ -> e
|
|
|
|
| _ -> Caddrof e
|
|
|
|
|
2011-07-22 10:52:31 +02:00
|
|
|
let inputlist_of_ovarlist vl =
|
|
|
|
let cvar_of_ovar vd =
|
|
|
|
let ty = ctype_of_otype vd.v_type in
|
2011-09-09 13:54:29 +02:00
|
|
|
let ty = if vd.v_mutable then pointer_type vd.v_type ty else ty in
|
2011-07-22 10:52:31 +02:00
|
|
|
name vd.v_ident, ty
|
|
|
|
in
|
|
|
|
List.map cvar_of_ovar vl
|
|
|
|
|
2010-07-26 17:41:52 +02:00
|
|
|
(** @return the unaliased version of a type. *)
|
2011-05-30 10:06:16 +02:00
|
|
|
let rec unalias_ctype cty = match cty with
|
2010-07-26 17:41:52 +02:00
|
|
|
| Cty_id ty_name ->
|
2011-05-30 10:06:16 +02:00
|
|
|
(try match find_type ty_name with
|
|
|
|
| Talias ty -> unalias_ctype (ctype_of_otype ty)
|
|
|
|
| _ -> Cty_id ty_name
|
|
|
|
with Not_found -> Cty_id ty_name)
|
2010-07-26 17:41:52 +02:00
|
|
|
| Cty_arr (n, cty) -> Cty_arr (n, unalias_ctype cty)
|
|
|
|
| Cty_ptr cty -> Cty_ptr (unalias_ctype cty)
|
|
|
|
| cty -> cty
|
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
(** Returns the type associated with the name [n]
|
|
|
|
in the environnement [var_env] (which is an association list
|
|
|
|
mapping strings to cty). *)
|
|
|
|
and assoc_type n var_env =
|
|
|
|
try unalias_ctype (List.assoc n var_env)
|
|
|
|
with Not_found -> Error.message no_location (Error.Evar n)
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** Returns the type associated with the lhs [lhs]
|
|
|
|
in the environnement [var_env] (which is an association list
|
|
|
|
mapping strings to cty).*)
|
2011-05-30 10:06:16 +02:00
|
|
|
let rec assoc_type_lhs lhs var_env = match lhs with
|
|
|
|
| CLvar x -> unalias_ctype (assoc_type x var_env)
|
|
|
|
| CLarray (lhs, _) ->
|
|
|
|
let ty = assoc_type_lhs lhs var_env in
|
|
|
|
array_base_ctype ty [1]
|
|
|
|
| CLderef lhs ->
|
|
|
|
(match assoc_type_lhs lhs var_env with
|
|
|
|
| Cty_ptr ty -> ty
|
|
|
|
| _ -> Error.message no_location Error.Ederef_not_pointer)
|
|
|
|
| CLfield(CLderef (CLvar "self"), { name = x }) -> assoc_type x var_env
|
2011-09-06 14:42:34 +02:00
|
|
|
| CLfield(CLderef (CLvar "_out"), { name = x }) -> assoc_type x var_env
|
2011-05-30 10:06:16 +02:00
|
|
|
| CLfield(x, f) ->
|
|
|
|
let ty = assoc_type_lhs x var_env in
|
|
|
|
let n = struct_name ty in
|
|
|
|
let fields = find_struct n in
|
|
|
|
ctype_of_otype (field_assoc f fields)
|
2010-06-16 11:32:13 +02:00
|
|
|
|
|
|
|
(** Creates the statement a = [e_1, e_2, ..], which gives a list
|
|
|
|
a[i] = e_i.*)
|
2010-06-26 16:53:25 +02:00
|
|
|
let rec create_affect_lit dest l ty =
|
2010-06-16 11:32:13 +02:00
|
|
|
let rec _create_affect_lit dest i = function
|
|
|
|
| [] -> []
|
2010-06-26 16:53:25 +02:00
|
|
|
| v::l ->
|
2011-05-30 10:06:16 +02:00
|
|
|
let stm = create_affect_stm (CLarray (dest, Cconst (Ccint i))) v ty in
|
2010-06-26 16:53:25 +02:00
|
|
|
stm@(_create_affect_lit dest (i+1) l)
|
2010-06-16 11:32:13 +02:00
|
|
|
in
|
2010-06-26 16:53:25 +02:00
|
|
|
_create_affect_lit dest 0 l
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** Creates the expression dest <- src (copying arrays if necessary). *)
|
2010-06-16 11:32:13 +02:00
|
|
|
and create_affect_stm dest src ty =
|
2010-10-02 12:59:44 +02:00
|
|
|
match ty with
|
2010-06-15 10:49:03 +02:00
|
|
|
| Cty_arr (n, bty) ->
|
2010-06-26 16:53:25 +02:00
|
|
|
(match src with
|
|
|
|
| Carraylit l -> create_affect_lit dest l bty
|
2011-05-30 10:06:16 +02:00
|
|
|
| src ->
|
|
|
|
let x = gen_symbol () in
|
|
|
|
[Cfor(x,
|
|
|
|
Cconst (Ccint 0), Cconst (Ccint n),
|
|
|
|
create_affect_stm
|
|
|
|
(CLarray (dest, Cvar x))
|
|
|
|
(Carray (src, Cvar x)) bty)]
|
2010-06-26 16:53:25 +02:00
|
|
|
)
|
2010-10-02 13:19:21 +02:00
|
|
|
| Cty_id ln ->
|
|
|
|
(match src with
|
|
|
|
| Cstructlit (_, ce_list) ->
|
2014-03-18 11:01:56 +01:00
|
|
|
let create_affect { Signature.f_name = f_name;
|
2010-10-02 13:19:21 +02:00
|
|
|
Signature.f_type = f_type; } e stm_list =
|
|
|
|
let cty = ctype_of_otype f_type in
|
2011-05-30 10:06:16 +02:00
|
|
|
create_affect_stm (CLfield (dest, f_name)) e cty @ stm_list in
|
2010-10-02 13:19:21 +02:00
|
|
|
List.fold_right2 create_affect (find_struct ln) ce_list []
|
|
|
|
| _ -> [Caffect (dest, src)])
|
2010-06-15 10:49:03 +02:00
|
|
|
| _ -> [Caffect (dest, src)]
|
|
|
|
|
2010-07-13 16:23:26 +02:00
|
|
|
let rec cexpr_of_static_exp se =
|
|
|
|
match se.se_desc with
|
|
|
|
| Sint i -> Cconst (Ccint i)
|
|
|
|
| Sfloat f -> Cconst (Ccfloat f)
|
2010-11-04 18:06:11 +01:00
|
|
|
| Sbool b -> Cconst (Ctag (if b then "true" else "false"))
|
2011-05-10 16:55:46 +02:00
|
|
|
| Sstring s -> Cconst (Cstrlit s)
|
2010-09-14 09:39:02 +02:00
|
|
|
| Sfield _ -> assert false
|
2010-09-13 09:37:58 +02:00
|
|
|
| Sconstructor c -> Cconst (Ctag (cname_of_qn c))
|
2010-07-19 15:16:14 +02:00
|
|
|
| Sarray sl -> Carraylit (List.map cexpr_of_static_exp sl)
|
2011-01-18 17:52:44 +01:00
|
|
|
| Srecord fl ->
|
|
|
|
let ty_name =
|
|
|
|
match Modules.unalias_type se.se_ty with
|
2013-03-15 09:31:19 +01:00
|
|
|
| Types.Tid n -> n
|
2011-01-18 17:52:44 +01:00
|
|
|
| _ -> assert false
|
|
|
|
in
|
2013-03-15 09:31:19 +01:00
|
|
|
let cexps_assoc = List.rev_map (fun (f, e) -> f, cexpr_of_static_exp e) fl in
|
|
|
|
cexpr_of_struct ty_name cexps_assoc
|
2011-05-26 18:39:33 +02:00
|
|
|
| Sarray_power(c,n_list) ->
|
2011-06-28 14:45:15 +02:00
|
|
|
(List.fold_left (fun cc n -> Carraylit (repeat_list cc (int_of_static_exp n)))
|
2011-05-26 18:39:33 +02:00
|
|
|
(cexpr_of_static_exp c) n_list)
|
2010-07-13 16:23:26 +02:00
|
|
|
| Svar ln ->
|
2012-02-08 18:31:51 +01:00
|
|
|
if !Compiler_options.unroll_loops && se.se_ty = Initial.tint
|
2014-03-18 11:01:56 +01:00
|
|
|
then cexpr_of_static_exp
|
|
|
|
(Static.simplify QualEnv.empty (find_const ln).Signature.c_value)
|
2012-02-08 17:47:28 +01:00
|
|
|
else Cvar (cname_of_qn ln)
|
2010-07-16 12:04:51 +02:00
|
|
|
| Sop _ ->
|
2010-09-10 14:29:13 +02:00
|
|
|
let se' = Static.simplify QualEnv.empty se in
|
2010-07-16 12:04:51 +02:00
|
|
|
if se = se' then
|
|
|
|
Error.message se.se_loc Error.Estatic_exp_compute_failed
|
|
|
|
else
|
|
|
|
cexpr_of_static_exp se'
|
2011-07-21 11:54:52 +02:00
|
|
|
| Stuple _ -> Misc.internal_error "cgen: static tuple"
|
2011-01-18 17:52:44 +01:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *)
|
2013-03-15 09:31:19 +01:00
|
|
|
and cexpr_of_exp out_env var_env exp =
|
2010-07-09 09:31:12 +02:00
|
|
|
match exp.e_desc with
|
2011-05-30 10:06:16 +02:00
|
|
|
| Eextvalue w -> cexpr_of_ext_value out_env var_env w
|
|
|
|
(** Operators *)
|
|
|
|
| Eop(op, exps) -> cop_of_op out_env var_env op exps
|
|
|
|
(** Structure literals. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Estruct (tyn, fl) ->
|
2013-03-15 09:31:19 +01:00
|
|
|
let cexpr = cexpr_of_exp out_env var_env in
|
|
|
|
let cexps_assoc = List.rev_map (fun (f, e) -> f, cexpr e) fl in
|
|
|
|
cexpr_of_struct tyn cexps_assoc
|
2010-07-09 09:31:12 +02:00
|
|
|
| Earray e_list ->
|
2011-05-30 10:06:16 +02:00
|
|
|
Carraylit (cexprs_of_exps out_env var_env e_list)
|
2010-06-16 11:32:13 +02:00
|
|
|
|
2013-03-15 09:31:19 +01:00
|
|
|
and cexpr_of_struct tyn cexps_assoc =
|
|
|
|
let cexps = List.fold_left
|
|
|
|
(fun cexps { Signature.f_name = f } -> List.assoc f cexps_assoc :: cexps)
|
|
|
|
[] (find_struct tyn) in
|
|
|
|
(* Reverse `cexps' here because of the previous use of `List.fold_left'. *)
|
|
|
|
Cstructlit (cname_of_qn tyn, List.rev cexps)
|
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
and cexprs_of_exps out_env var_env exps =
|
|
|
|
List.map (cexpr_of_exp out_env var_env) exps
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-09-14 09:39:02 +02:00
|
|
|
and cop_of_op_aux op_name cexps = match op_name with
|
2011-02-07 14:24:17 +01:00
|
|
|
| { qual = Pervasives; name = op } ->
|
2010-06-16 11:32:13 +02:00
|
|
|
begin match op,cexps with
|
2011-09-06 11:54:03 +02:00
|
|
|
| ("~-" | "~-."), [e] -> Cuop ("-", e)
|
2011-12-05 17:10:02 +01:00
|
|
|
| ("~~"), [e] -> Cuop ("~", e)
|
2010-06-16 11:32:13 +02:00
|
|
|
| "not", [e] -> Cuop ("!", e)
|
|
|
|
| (
|
|
|
|
"=" | "<>"
|
|
|
|
| "&" | "or"
|
|
|
|
| "+" | "-" | "*" | "/"
|
2011-12-06 17:46:35 +01:00
|
|
|
| "*." | "/." | "+." | "-." | "%" | "<<<" | ">>>" | "&&&" | "|||"
|
2011-09-06 11:54:03 +02:00
|
|
|
| "<" | ">" | "<=" | ">=" | "<=." | "<." | ">=." | ">."), [el;er] ->
|
2010-06-16 11:32:13 +02:00
|
|
|
Cbop (copname op, el, er)
|
|
|
|
| _ -> Cfun_call(op, cexps)
|
|
|
|
end
|
2011-11-22 14:43:52 +01:00
|
|
|
| { qual = Module "Iostream"; name = "printf" } ->
|
|
|
|
let s, args = assert_1min cexps in
|
|
|
|
let s = cformat_of_format s in
|
|
|
|
Cfun_call("printf", s::args)
|
|
|
|
| { qual = Module "Iostream"; name = "fprintf" } ->
|
|
|
|
let file, s, args = assert_2min cexps in
|
|
|
|
let s = cformat_of_format s in
|
|
|
|
Cfun_call("fprintf", file::s::args)
|
2011-06-28 14:45:15 +02:00
|
|
|
| { name = op } -> Cfun_call(op,cexps)
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
and cop_of_op out_env var_env op_name exps =
|
|
|
|
let cexps = cexprs_of_exps out_env var_env exps in
|
2010-09-14 09:39:02 +02:00
|
|
|
cop_of_op_aux op_name cexps
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
and clhs_of_pattern out_env var_env l = match l.pat_desc with
|
2010-06-26 16:53:25 +02:00
|
|
|
(** Each Obc variable corresponds to a real local C variable. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Lvar v ->
|
2010-06-15 10:49:03 +02:00
|
|
|
let n = name v in
|
2011-05-30 10:06:16 +02:00
|
|
|
let n_lhs =
|
|
|
|
if IdentSet.mem v out_env
|
2011-09-06 14:42:34 +02:00
|
|
|
then CLfield (CLderef (CLvar "_out"), local_qn n)
|
2011-05-30 10:06:16 +02:00
|
|
|
else CLvar n
|
|
|
|
in
|
|
|
|
|
2010-06-26 16:53:25 +02:00
|
|
|
if List.mem_assoc n var_env then
|
|
|
|
let ty = assoc_type n var_env in
|
|
|
|
(match ty with
|
2011-05-30 10:06:16 +02:00
|
|
|
| Cty_ptr _ -> CLderef n_lhs
|
|
|
|
| _ -> n_lhs
|
2010-06-26 16:53:25 +02:00
|
|
|
)
|
|
|
|
else
|
2011-05-30 10:06:16 +02:00
|
|
|
n_lhs
|
2010-06-18 10:55:16 +02:00
|
|
|
(** Dereference our [self] struct holding the node's memory. *)
|
2011-05-30 10:06:16 +02:00
|
|
|
| Lmem v -> CLfield (CLderef (CLvar "self"), local_qn (name v))
|
2010-06-26 16:53:25 +02:00
|
|
|
(** Field access. /!\ Indexed Obj expression should be a valid lhs! *)
|
2011-05-30 10:06:16 +02:00
|
|
|
| Lfield (l, fn) -> CLfield(clhs_of_pattern out_env var_env l, fn)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Larray (l, idx) ->
|
2011-05-30 10:06:16 +02:00
|
|
|
CLarray(clhs_of_pattern out_env var_env l,
|
|
|
|
cexpr_of_exp out_env var_env idx)
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
and clhs_list_of_pattern_list out_env var_env lhss =
|
|
|
|
List.map (clhs_of_pattern out_env var_env) lhss
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
and cexpr_of_pattern out_env var_env l = match l.pat_desc with
|
|
|
|
(** Each Obc variable corresponds to a real local C variable. *)
|
|
|
|
| Lvar v ->
|
|
|
|
let n = name v in
|
|
|
|
let n_lhs =
|
|
|
|
if IdentSet.mem v out_env
|
2011-09-06 14:42:34 +02:00
|
|
|
then Cfield (Cderef (Cvar "_out"), local_qn n)
|
2011-05-30 10:06:16 +02:00
|
|
|
else Cvar n
|
|
|
|
in
|
|
|
|
|
|
|
|
if List.mem_assoc n var_env then
|
|
|
|
let ty = assoc_type n var_env in
|
|
|
|
(match ty with
|
|
|
|
| Cty_ptr _ -> Cderef n_lhs
|
|
|
|
| _ -> n_lhs
|
|
|
|
)
|
|
|
|
else
|
|
|
|
n_lhs
|
|
|
|
(** Dereference our [self] struct holding the node's memory. *)
|
|
|
|
| Lmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v))
|
|
|
|
(** Field access. /!\ Indexed Obj expression should be a valid lhs! *)
|
|
|
|
| Lfield (l, fn) -> Cfield(cexpr_of_pattern out_env var_env l, fn)
|
|
|
|
| Larray (l, idx) ->
|
|
|
|
Carray(cexpr_of_pattern out_env var_env l,
|
|
|
|
cexpr_of_exp out_env var_env idx)
|
|
|
|
|
|
|
|
and cexpr_of_ext_value out_env var_env w = match w.w_desc with
|
|
|
|
| Wconst c -> cexpr_of_static_exp c
|
|
|
|
(** Each Obc variable corresponds to a plain local C variable. *)
|
|
|
|
| Wvar v ->
|
|
|
|
let n = name v in
|
|
|
|
let n_lhs =
|
|
|
|
if IdentSet.mem v out_env
|
2011-09-06 14:42:34 +02:00
|
|
|
then Cfield (Cderef (Cvar "_out"), local_qn n)
|
2011-05-30 10:06:16 +02:00
|
|
|
else Cvar n
|
|
|
|
in
|
|
|
|
|
|
|
|
if List.mem_assoc n var_env then
|
|
|
|
let ty = assoc_type n var_env in
|
|
|
|
(match ty with
|
|
|
|
| Cty_ptr _ -> Cderef n_lhs
|
|
|
|
| _ -> n_lhs)
|
|
|
|
else
|
|
|
|
n_lhs
|
|
|
|
(** Dereference our [self] struct holding the node's memory. *)
|
|
|
|
| Wmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v))
|
|
|
|
(** Field access. /!\ Indexed Obj expression should be a valid lhs! *)
|
|
|
|
| Wfield (l, fn) -> Cfield(cexpr_of_ext_value out_env var_env l, fn)
|
|
|
|
| Warray (l, idx) ->
|
|
|
|
Carray(cexpr_of_ext_value out_env var_env l,
|
|
|
|
cexpr_of_exp out_env var_env idx)
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
let rec assoc_obj instance obj_env =
|
|
|
|
match obj_env with
|
|
|
|
| [] -> raise Not_found
|
|
|
|
| od :: t ->
|
2011-03-08 09:22:02 +01:00
|
|
|
if od.o_ident = instance
|
2010-06-15 10:49:03 +02:00
|
|
|
then od
|
|
|
|
else assoc_obj instance t
|
|
|
|
|
|
|
|
let assoc_cn instance obj_env =
|
2010-11-05 15:36:11 +01:00
|
|
|
(assoc_obj (obj_ref_name instance) obj_env).o_class
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
let is_op = function
|
2011-02-07 14:24:17 +01:00
|
|
|
| { qual = Pervasives; name = _ } -> true
|
2010-06-15 10:49:03 +02:00
|
|
|
| _ -> false
|
|
|
|
|
2010-06-30 17:30:24 +02:00
|
|
|
let out_var_name_of_objn o =
|
|
|
|
o ^"_out_st"
|
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Creates the list of arguments to call a node. [targeting] is the targeting
|
|
|
|
of the called node, [mem] represents the node context and [args] the
|
|
|
|
argument list.*)
|
2011-05-30 10:06:16 +02:00
|
|
|
let step_fun_call out_env var_env sig_info objn out args =
|
2011-04-26 18:36:00 +02:00
|
|
|
let rec add_targeting l ads = match l, ads with
|
|
|
|
| [], [] -> []
|
|
|
|
| e::l, ad::ads ->
|
|
|
|
(*this arg is targeted, use a pointer*)
|
2011-07-05 17:46:43 +02:00
|
|
|
let e = if Linearity.is_linear ad.a_linearity then address_of ad.a_type e else e in
|
2011-04-26 18:36:00 +02:00
|
|
|
e::(add_targeting l ads)
|
|
|
|
| _, _ -> assert false
|
|
|
|
in
|
|
|
|
let args = (add_targeting args sig_info.node_inputs) in
|
2011-03-21 14:30:19 +01:00
|
|
|
if sig_info.node_stateful then (
|
2010-06-30 17:30:24 +02:00
|
|
|
let mem =
|
|
|
|
(match objn with
|
2011-03-08 09:22:02 +01:00
|
|
|
| Oobj o -> Cfield (Cderef (Cvar "self"), local_qn (name o))
|
2010-07-09 09:31:12 +02:00
|
|
|
| Oarray (o, l) ->
|
2011-06-27 10:58:14 +02:00
|
|
|
let f = Cfield (Cderef (Cvar "self"), local_qn (name o)) in
|
2011-06-27 19:20:47 +02:00
|
|
|
let rec mk_idx pl = match pl with
|
2011-06-27 10:58:14 +02:00
|
|
|
| [] -> f
|
2011-06-27 16:08:56 +02:00
|
|
|
| p::pl -> Carray (mk_idx pl, cexpr_of_pattern out_env var_env p)
|
2011-06-27 10:58:14 +02:00
|
|
|
in
|
|
|
|
mk_idx l
|
2010-06-30 17:30:24 +02:00
|
|
|
) in
|
|
|
|
args@[Caddrof out; Caddrof mem]
|
|
|
|
) else
|
|
|
|
args@[Caddrof out]
|
2010-06-16 11:32:13 +02:00
|
|
|
|
|
|
|
(** Generate the statement to call [objn].
|
|
|
|
[outvl] is a list of lhs where to put the results.
|
2010-06-15 10:49:03 +02:00
|
|
|
[args] is the list of expressions to use as arguments.
|
|
|
|
[mem] is the lhs where is stored the node's context.*)
|
2011-05-30 10:06:16 +02:00
|
|
|
let generate_function_call out_env var_env obj_env outvl objn args =
|
2010-06-26 16:53:25 +02:00
|
|
|
(** Class name for the object to step. *)
|
2010-06-15 10:49:03 +02:00
|
|
|
let classln = assoc_cn objn obj_env in
|
2010-09-13 09:37:58 +02:00
|
|
|
let classn = cname_of_qn classln in
|
2010-09-10 11:53:55 +02:00
|
|
|
let sig_info = find_value classln in
|
2010-06-30 17:30:24 +02:00
|
|
|
let out = Cvar (out_var_name_of_objn classn) in
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
let fun_call =
|
2010-06-15 10:49:03 +02:00
|
|
|
if is_op classln then
|
2010-09-14 09:39:02 +02:00
|
|
|
cop_of_op_aux classln args
|
2010-06-15 10:49:03 +02:00
|
|
|
else
|
|
|
|
(** The step function takes scalar arguments and its own internal memory
|
2010-06-16 11:32:13 +02:00
|
|
|
holding structure. *)
|
2011-05-30 10:06:16 +02:00
|
|
|
let args = step_fun_call out_env var_env sig_info objn out args in
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Our C expression for the function call. *)
|
2010-06-26 16:53:25 +02:00
|
|
|
Cfun_call (classn ^ "_step", args)
|
2010-06-15 10:49:03 +02:00
|
|
|
in
|
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
(** Act according to the length of our list. Step functions with
|
2011-04-27 14:02:50 +02:00
|
|
|
multiple return values will return a structure, and we care of
|
2010-06-16 11:32:13 +02:00
|
|
|
assigning each field to the corresponding local variable. *)
|
|
|
|
match outvl with
|
|
|
|
| [] -> [Csexpr fun_call]
|
2010-06-30 17:30:24 +02:00
|
|
|
| [outv] when is_op classln ->
|
|
|
|
let ty = assoc_type_lhs outv var_env in
|
2011-04-27 14:02:50 +02:00
|
|
|
create_affect_stm outv fun_call ty
|
2010-06-16 11:32:13 +02:00
|
|
|
| _ ->
|
|
|
|
(* Remove options *)
|
|
|
|
let out_sig = output_names_list sig_info in
|
|
|
|
let create_affect outv out_name =
|
2010-06-30 17:30:24 +02:00
|
|
|
let ty = assoc_type_lhs outv var_env in
|
2011-05-30 10:06:16 +02:00
|
|
|
create_affect_stm outv (Cfield (out, local_qn out_name)) ty
|
2010-06-30 17:30:24 +02:00
|
|
|
in
|
|
|
|
(Csexpr fun_call)::(List.flatten (map2 create_affect outvl out_sig))
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** Create the statement dest = c where c = v^n^m... *)
|
2011-05-30 10:06:16 +02:00
|
|
|
let rec create_affect_const var_env (dest : clhs) c =
|
2010-07-09 09:31:12 +02:00
|
|
|
match c.se_desc with
|
2010-10-02 13:17:12 +02:00
|
|
|
| Svar ln ->
|
2014-03-18 11:01:56 +01:00
|
|
|
let se = Static.simplify QualEnv.empty (find_const ln).Signature.c_value in
|
2010-10-02 13:17:12 +02:00
|
|
|
create_affect_const var_env dest se
|
2011-05-26 18:39:33 +02:00
|
|
|
| Sarray_power(c, n_list) ->
|
|
|
|
let rec make_loop power_list replace = match power_list with
|
|
|
|
| [] -> dest, replace
|
|
|
|
| p :: power_list ->
|
|
|
|
let x = gen_symbol () in
|
2011-06-28 14:45:15 +02:00
|
|
|
let e, replace =
|
|
|
|
make_loop power_list
|
2011-05-26 18:39:33 +02:00
|
|
|
(fun y -> [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp p, replace y)]) in
|
2011-05-30 10:06:16 +02:00
|
|
|
let e = (CLarray (e, Cvar x)) in
|
2011-05-26 18:39:33 +02:00
|
|
|
e, replace
|
|
|
|
in
|
|
|
|
let e, b = make_loop n_list (fun y -> y) in
|
|
|
|
b (create_affect_const var_env e c)
|
2010-07-19 15:16:14 +02:00
|
|
|
| Sarray cl ->
|
|
|
|
let create_affect_idx c (i, affl) =
|
2011-05-30 10:06:16 +02:00
|
|
|
let dest = CLarray (dest, Cconst (Ccint i)) in
|
2011-05-03 13:21:27 +02:00
|
|
|
(i - 1, create_affect_const var_env dest c @ affl)
|
|
|
|
in
|
|
|
|
snd (List.fold_right create_affect_idx cl (List.length cl - 1, []))
|
|
|
|
| Srecord f_se_list ->
|
|
|
|
let affect_field affl (f, se) =
|
2011-05-30 10:06:16 +02:00
|
|
|
let dest_f = CLfield (dest, f) in
|
2011-05-03 13:21:27 +02:00
|
|
|
(create_affect_const var_env dest_f se) @ affl
|
|
|
|
in
|
|
|
|
List.fold_left affect_field [] f_se_list
|
2011-03-08 09:22:02 +01:00
|
|
|
| _ -> [Caffect (dest, cexpr_of_static_exp c)]
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
(** [cstm_of_act obj_env mods act] translates the Obj action [act] to a list of
|
|
|
|
C statements, using the association list [obj_env] to map object names to
|
|
|
|
class names. *)
|
2011-05-30 10:06:16 +02:00
|
|
|
let rec cstm_of_act out_env var_env obj_env act =
|
2010-06-15 10:49:03 +02:00
|
|
|
match act with
|
2010-11-04 18:06:11 +01:00
|
|
|
(** Cosmetic : cases on boolean values are converted to if statements. *)
|
2010-09-09 00:35:06 +02:00
|
|
|
| Acase (c, [({name = "true"}, te); ({ name = "false" }, fe)])
|
|
|
|
| Acase (c, [({name = "false"}, fe); ({ name = "true"}, te)]) ->
|
2011-05-30 10:06:16 +02:00
|
|
|
let cc = cexpr_of_exp out_env var_env c in
|
|
|
|
let cte = cstm_of_act_list out_env var_env obj_env te in
|
|
|
|
let cfe = cstm_of_act_list out_env var_env obj_env fe in
|
2010-06-15 10:49:03 +02:00
|
|
|
[Cif (cc, cte, cfe)]
|
2010-11-04 18:06:11 +01:00
|
|
|
| Acase (c, [({name = "true"}, te)]) ->
|
2011-05-30 10:06:16 +02:00
|
|
|
let cc = cexpr_of_exp out_env var_env c in
|
|
|
|
let cte = cstm_of_act_list out_env var_env obj_env te in
|
2010-11-04 18:06:11 +01:00
|
|
|
let cfe = [] in
|
|
|
|
[Cif (cc, cte, cfe)]
|
|
|
|
| Acase (c, [({name = "false"}, fe)]) ->
|
2011-05-30 10:06:16 +02:00
|
|
|
let cc = Cuop ("!", (cexpr_of_exp out_env var_env c)) in
|
|
|
|
let cte = cstm_of_act_list out_env var_env obj_env fe in
|
2010-11-04 18:06:11 +01:00
|
|
|
let cfe = [] in
|
|
|
|
[Cif (cc, cte, cfe)]
|
|
|
|
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2010-06-18 10:55:16 +02:00
|
|
|
(** Translation of case into a C switch statement is simple enough: we
|
|
|
|
just recursively translate obj expressions and statements to
|
|
|
|
corresponding C constructs, and cautiously "shortnamize"
|
|
|
|
constructor names. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Acase (e, cl) ->
|
2010-06-15 10:49:03 +02:00
|
|
|
(** [ccl_of_obccl] translates an Obc clause to a C clause. *)
|
|
|
|
let ccl =
|
2010-06-16 11:32:13 +02:00
|
|
|
List.map
|
2010-09-13 09:37:58 +02:00
|
|
|
(fun (c,act) -> cname_of_qn c,
|
2011-05-30 10:06:16 +02:00
|
|
|
cstm_of_act_list out_env var_env obj_env act) cl in
|
|
|
|
[Cswitch (cexpr_of_exp out_env var_env e, ccl)]
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2011-03-08 09:22:02 +01:00
|
|
|
| Ablock b ->
|
2011-05-30 10:06:16 +02:00
|
|
|
cstm_of_act_list out_env var_env obj_env b
|
2011-03-08 09:22:02 +01:00
|
|
|
|
2010-06-18 10:55:16 +02:00
|
|
|
(** For composition of statements, just recursively apply our
|
|
|
|
translation function on sub-statements. *)
|
2011-03-21 14:30:19 +01:00
|
|
|
| Afor ({ v_ident = x }, i1, i2, act) ->
|
2011-05-30 10:06:16 +02:00
|
|
|
[Cfor(name x, cexpr_of_exp out_env var_env i1,
|
|
|
|
cexpr_of_exp out_env var_env i2,
|
|
|
|
cstm_of_act_list out_env var_env obj_env act)]
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
(** Translate constant assignment *)
|
2011-06-28 14:45:15 +02:00
|
|
|
| Aassgn (vn, { e_desc = Eextvalue { w_desc = Wconst c }; }) ->
|
2011-05-30 10:06:16 +02:00
|
|
|
let vn = clhs_of_pattern out_env var_env vn in
|
2011-01-11 14:46:28 +01:00
|
|
|
create_affect_const var_env vn c
|
|
|
|
|
|
|
|
(** Purely syntactic translation from an Obc local variable to a C
|
|
|
|
local one, with recursive translation of the rhs expression. *)
|
|
|
|
| Aassgn (vn, e) ->
|
2011-05-30 10:06:16 +02:00
|
|
|
let vn = clhs_of_pattern out_env var_env vn in
|
2011-01-11 14:46:28 +01:00
|
|
|
let ty = assoc_type_lhs vn var_env in
|
2011-05-30 10:06:16 +02:00
|
|
|
let ce = cexpr_of_exp out_env var_env e in
|
2011-01-11 14:46:28 +01:00
|
|
|
create_affect_stm vn ce ty
|
|
|
|
|
2011-04-28 15:20:21 +02:00
|
|
|
(** Our Aop marks an operator invocation that will perform side effects. Just
|
|
|
|
translate to a simple C statement. *)
|
|
|
|
| Aop (op_name, args) ->
|
2011-05-30 10:06:16 +02:00
|
|
|
[Csexpr (cop_of_op out_env var_env op_name args)]
|
2011-04-28 15:20:21 +02:00
|
|
|
|
2010-06-18 10:55:16 +02:00
|
|
|
(** Reinitialization of an object variable, extracting the reset
|
|
|
|
function's name from our environment [obj_env]. *)
|
2010-09-13 13:32:35 +02:00
|
|
|
| Acall (name_list, o, Mreset, args) ->
|
|
|
|
assert_empty name_list;
|
|
|
|
assert_empty args;
|
2010-11-05 15:36:11 +01:00
|
|
|
let on = obj_ref_name o in
|
2010-06-16 11:32:13 +02:00
|
|
|
let obj = assoc_obj on obj_env in
|
2010-09-13 09:37:58 +02:00
|
|
|
let classn = cname_of_qn obj.o_class in
|
2011-07-08 10:51:10 +02:00
|
|
|
let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in
|
|
|
|
(match o with
|
|
|
|
| Oobj _ ->
|
|
|
|
[Csexpr (Cfun_call (classn ^ "_reset", [Caddrof field]))]
|
|
|
|
| Oarray (_, pl) ->
|
|
|
|
let rec mk_loop pl field = match pl with
|
|
|
|
| [] ->
|
|
|
|
[Csexpr (Cfun_call (classn ^ "_reset", [Caddrof field]))]
|
|
|
|
| p::pl ->
|
|
|
|
mk_loop pl (Carray(field, cexpr_of_pattern out_env var_env p))
|
|
|
|
in
|
|
|
|
mk_loop pl field
|
2010-07-09 09:31:12 +02:00
|
|
|
)
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2010-06-18 10:55:16 +02:00
|
|
|
(** Step functions applications can return multiple values, so we use a
|
|
|
|
local structure to hold the results, before allocating to our
|
|
|
|
variables. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
| Acall (outvl, objn, Mstep, el) ->
|
2011-05-30 10:06:16 +02:00
|
|
|
let args = cexprs_of_exps out_env var_env el in
|
|
|
|
let outvl = clhs_list_of_pattern_list out_env var_env outvl in
|
|
|
|
generate_function_call out_env var_env obj_env outvl objn args
|
2010-06-26 16:53:25 +02:00
|
|
|
|
2010-09-13 13:32:35 +02:00
|
|
|
|
2011-05-30 10:06:16 +02:00
|
|
|
and cstm_of_act_list out_env var_env obj_env b =
|
2010-07-22 09:36:22 +02:00
|
|
|
let l = List.map cvar_of_vd b.b_locals in
|
|
|
|
let var_env = l @ var_env in
|
2011-05-30 10:06:16 +02:00
|
|
|
let cstm = List.flatten (List.map (cstm_of_act out_env var_env obj_env) b.b_body) in
|
2010-07-22 09:36:22 +02:00
|
|
|
match l with
|
|
|
|
| [] -> cstm
|
|
|
|
| _ ->
|
|
|
|
[Csblock { var_decls = l; block_body = cstm }]
|
2010-06-16 11:32:13 +02:00
|
|
|
|
|
|
|
(* TODO needed only because of renaming phase *)
|
|
|
|
let global_name = ref "";;
|
|
|
|
|
2010-06-27 14:01:06 +02:00
|
|
|
|
2010-06-16 11:32:13 +02:00
|
|
|
|
2013-11-08 18:51:06 +01:00
|
|
|
(** {2 step() and reset() functions generation} *)
|
2010-06-16 11:32:13 +02:00
|
|
|
|
2010-09-13 15:16:12 +02:00
|
|
|
let qn_append q suffix =
|
|
|
|
{ qual = q.qual; name = q.name ^ suffix }
|
2010-06-16 11:32:13 +02:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** Builds the argument list of step function*)
|
2010-07-16 11:27:41 +02:00
|
|
|
let step_fun_args n md =
|
2011-07-22 10:52:31 +02:00
|
|
|
let args = inputlist_of_ovarlist md.m_inputs in
|
2011-09-06 14:42:34 +02:00
|
|
|
let out_arg = [("_out", Cty_ptr (Cty_id (qn_append n "_out")))] in
|
2010-06-30 17:30:24 +02:00
|
|
|
let context_arg =
|
2011-03-21 14:30:19 +01:00
|
|
|
if is_stateful n then
|
2010-09-13 15:16:12 +02:00
|
|
|
[("self", Cty_ptr (Cty_id (qn_append n "_mem")))]
|
2010-06-30 17:30:24 +02:00
|
|
|
else
|
|
|
|
[]
|
|
|
|
in
|
|
|
|
args @ out_arg @ context_arg
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** [fun_def_of_step_fun name obj_env mods sf] returns a C function definition
|
|
|
|
[name ^ "_out"] corresponding to the Obc step function [sf]. The object name
|
|
|
|
<-> class name mapping [obj_env] is needed to translate internal steps and
|
|
|
|
reset calls. A step function can have multiple return values, whereas C does
|
|
|
|
not allow such functions. When it is the case, we declare a structure with a
|
2010-06-30 17:30:24 +02:00
|
|
|
field by return value. *)
|
2010-09-13 09:37:58 +02:00
|
|
|
let fun_def_of_step_fun n obj_env mem objs md =
|
|
|
|
let fun_name = (cname_of_qn n) ^ "_step" in
|
2010-06-15 10:49:03 +02:00
|
|
|
(** Its arguments, translating Obc types to C types and adding our internal
|
|
|
|
memory structure. *)
|
2010-09-13 09:37:58 +02:00
|
|
|
let args = step_fun_args n md in
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2010-06-30 17:30:24 +02:00
|
|
|
(** Out vars for function calls *)
|
|
|
|
let out_vars =
|
2010-07-07 14:44:18 +02:00
|
|
|
unique
|
2010-09-13 09:37:58 +02:00
|
|
|
(List.map (fun obj -> out_var_name_of_objn (cname_of_qn obj.o_class),
|
2010-09-13 15:16:12 +02:00
|
|
|
Cty_id (qn_append obj.o_class "_out"))
|
2010-07-09 09:31:12 +02:00
|
|
|
(List.filter (fun obj -> not (is_op obj.o_class)) objs)) in
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** The body *)
|
2010-07-09 09:31:12 +02:00
|
|
|
let mems = List.map cvar_of_vd (mem@md.m_outputs) in
|
2010-07-26 17:41:52 +02:00
|
|
|
let var_env = args @ mems @ out_vars in
|
2011-05-30 10:06:16 +02:00
|
|
|
let out_env =
|
|
|
|
List.fold_left
|
|
|
|
(fun out_env vd -> IdentSet.add vd.v_ident out_env)
|
|
|
|
IdentSet.empty
|
|
|
|
md.m_outputs
|
|
|
|
in
|
|
|
|
let body = cstm_of_act_list out_env var_env obj_env md.m_body in
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
Cfundef {
|
2014-03-18 11:01:56 +01:00
|
|
|
C.f_name = fun_name;
|
2010-06-30 17:30:24 +02:00
|
|
|
f_retty = Cty_void;
|
2010-06-15 10:49:03 +02:00
|
|
|
f_args = args;
|
|
|
|
f_body = {
|
2010-07-22 17:38:11 +02:00
|
|
|
var_decls = out_vars;
|
2010-07-09 09:31:12 +02:00
|
|
|
block_body = body
|
2010-06-15 10:49:03 +02:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
(** [mem_decl_of_class_def cd] returns a declaration for a C structure holding
|
|
|
|
internal variables and objects of the Obc class definition [cd]. *)
|
|
|
|
let mem_decl_of_class_def cd =
|
|
|
|
(** This one just translates the class name to a struct name following the
|
|
|
|
convention we described above. *)
|
|
|
|
let struct_field_of_obj_dec l od =
|
2011-03-21 14:30:19 +01:00
|
|
|
if is_stateful od.o_class then
|
2010-09-13 15:16:12 +02:00
|
|
|
let ty = Cty_id (qn_append od.o_class "_mem") in
|
2010-07-09 09:31:12 +02:00
|
|
|
let ty = match od.o_size with
|
2011-06-27 10:58:14 +02:00
|
|
|
| Some nl ->
|
2011-06-27 19:20:47 +02:00
|
|
|
let rec mk_idx nl = match nl with
|
2011-06-27 10:58:14 +02:00
|
|
|
| [] -> ty
|
|
|
|
| n::nl -> Cty_arr (int_of_static_exp n, mk_idx nl)
|
|
|
|
in
|
|
|
|
mk_idx nl
|
2010-07-09 09:31:12 +02:00
|
|
|
| None -> ty in
|
2011-03-08 09:22:02 +01:00
|
|
|
(name od.o_ident, ty)::l
|
2010-06-15 10:49:03 +02:00
|
|
|
else
|
2010-06-30 17:30:24 +02:00
|
|
|
l
|
2010-06-15 10:49:03 +02:00
|
|
|
in
|
2011-03-21 14:30:19 +01:00
|
|
|
if is_stateful cd.cd_name then (
|
2010-06-30 17:30:24 +02:00
|
|
|
(** Fields corresponding to normal memory variables. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
let mem_fields = List.map cvar_of_vd cd.cd_mems in
|
2010-06-30 17:30:24 +02:00
|
|
|
(** Fields corresponding to object variables. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
let obj_fields = List.fold_left struct_field_of_obj_dec [] cd.cd_objs in
|
2010-09-13 09:37:58 +02:00
|
|
|
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_mem",
|
|
|
|
mem_fields @ obj_fields)]
|
2010-06-30 17:30:24 +02:00
|
|
|
) else
|
|
|
|
[]
|
|
|
|
|
|
|
|
let out_decl_of_class_def cd =
|
2010-07-07 09:58:12 +02:00
|
|
|
(** Fields corresponding to output variables. *)
|
2010-07-09 09:31:12 +02:00
|
|
|
let step_m = find_step_method cd in
|
|
|
|
let out_fields = List.map cvar_of_vd step_m.m_outputs in
|
2010-09-13 09:37:58 +02:00
|
|
|
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_out", out_fields)]
|
2010-06-15 10:49:03 +02:00
|
|
|
|
|
|
|
(** [reset_fun_def_of_class_def cd] returns the defintion of the C function
|
|
|
|
tasked to reset the class [cd]. *)
|
|
|
|
let reset_fun_def_of_class_def cd =
|
2011-03-21 14:30:19 +01:00
|
|
|
let body =
|
2011-07-21 11:54:52 +02:00
|
|
|
if cd.cd_stateful then
|
2011-03-21 14:30:19 +01:00
|
|
|
let var_env = List.map cvar_of_vd cd.cd_mems in
|
|
|
|
let reset = find_reset_method cd in
|
2011-05-30 10:06:16 +02:00
|
|
|
cstm_of_act_list IdentSet.empty var_env cd.cd_objs reset.m_body
|
2011-07-21 11:54:52 +02:00
|
|
|
else
|
|
|
|
[]
|
2011-03-21 14:30:19 +01:00
|
|
|
in
|
2010-06-15 10:49:03 +02:00
|
|
|
Cfundef {
|
2014-03-18 11:01:56 +01:00
|
|
|
C.f_name = (cname_of_qn cd.cd_name) ^ "_reset";
|
2010-06-15 10:49:03 +02:00
|
|
|
f_retty = Cty_void;
|
2010-09-13 15:16:12 +02:00
|
|
|
f_args = [("self", Cty_ptr (Cty_id (qn_append cd.cd_name "_mem")))];
|
2010-06-15 10:49:03 +02:00
|
|
|
f_body = {
|
|
|
|
var_decls = [];
|
|
|
|
block_body = body;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2011-03-21 14:30:19 +01:00
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** [cdecl_and_cfun_of_class_def cd] translates the class definition [cd] to
|
|
|
|
a C program. *)
|
|
|
|
let cdefs_and_cdecls_of_class_def cd =
|
|
|
|
(** We keep the state of our class in a structure, holding both internal
|
|
|
|
variables and the state of other nodes. For a class named ["cname"], the
|
|
|
|
structure will be called ["cname_mem"]. *)
|
2012-08-01 17:08:58 +02:00
|
|
|
Idents.enter_node cd.cd_name;
|
2010-07-09 09:31:12 +02:00
|
|
|
let step_m = find_step_method cd in
|
2010-06-15 10:49:03 +02:00
|
|
|
let memory_struct_decl = mem_decl_of_class_def cd in
|
2010-06-30 17:30:24 +02:00
|
|
|
let out_struct_decl = out_decl_of_class_def cd in
|
2010-09-13 09:37:58 +02:00
|
|
|
let step_fun_def = fun_def_of_step_fun cd.cd_name
|
|
|
|
cd.cd_objs cd.cd_mems cd.cd_objs step_m in
|
2010-06-15 10:49:03 +02:00
|
|
|
(** C function for resetting our memory structure. *)
|
|
|
|
let reset_fun_def = reset_fun_def_of_class_def cd in
|
|
|
|
let res_fun_decl = cdecl_of_cfundef reset_fun_def in
|
|
|
|
let step_fun_decl = cdecl_of_cfundef step_fun_def in
|
2010-07-27 16:27:07 +02:00
|
|
|
let (decls, defs) =
|
2011-03-21 14:30:19 +01:00
|
|
|
if is_stateful cd.cd_name then
|
2010-06-30 17:30:24 +02:00
|
|
|
([res_fun_decl; step_fun_decl], [reset_fun_def; step_fun_def])
|
|
|
|
else
|
|
|
|
([step_fun_decl], [step_fun_def]) in
|
|
|
|
|
2010-07-27 16:27:07 +02:00
|
|
|
memory_struct_decl @ out_struct_decl @ decls,
|
|
|
|
defs
|
2010-06-27 23:27:54 +02:00
|
|
|
|
|
|
|
(** {2 Type translation} *)
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
(** Translates an Obc type declaration to its C counterpart. *)
|
|
|
|
let cdefs_and_cdecls_of_type_decl otd =
|
2010-09-13 09:37:58 +02:00
|
|
|
let name = cname_of_qn otd.t_name in
|
2010-06-15 10:49:03 +02:00
|
|
|
match otd.t_desc with
|
|
|
|
| Type_abs -> [], [] (*assert false*)
|
2010-09-13 15:16:12 +02:00
|
|
|
| Type_alias ty ->
|
|
|
|
[], [Cdecl_typedef (ctype_of_otype ty, name)]
|
2010-06-15 10:49:03 +02:00
|
|
|
| Type_enum nl ->
|
|
|
|
let of_string_fun = Cfundef
|
2014-03-18 11:01:56 +01:00
|
|
|
{ C.f_name = name ^ "_of_string";
|
2010-09-13 15:16:12 +02:00
|
|
|
f_retty = Cty_id otd.t_name;
|
2010-06-15 10:49:03 +02:00
|
|
|
f_args = [("s", Cty_ptr Cty_char)];
|
|
|
|
f_body =
|
|
|
|
{ var_decls = [];
|
|
|
|
block_body =
|
|
|
|
let gen_if t =
|
2010-09-13 13:44:26 +02:00
|
|
|
let t = cname_of_qn t in
|
2011-05-30 10:06:16 +02:00
|
|
|
let funcall = Cfun_call ("strcmp", [Cvar "s";
|
2010-06-15 10:49:03 +02:00
|
|
|
Cconst (Cstrlit t)]) in
|
|
|
|
let cond = Cbop ("==", funcall, Cconst (Ccint 0)) in
|
|
|
|
Cif (cond, [Creturn (Cconst (Ctag t))], []) in
|
|
|
|
map gen_if nl; }
|
|
|
|
}
|
|
|
|
and to_string_fun = Cfundef
|
2014-03-18 11:01:56 +01:00
|
|
|
{ C.f_name = "string_of_" ^ name;
|
2010-06-15 10:49:03 +02:00
|
|
|
f_retty = Cty_ptr Cty_char;
|
2010-09-13 15:16:12 +02:00
|
|
|
f_args = [("x", Cty_id otd.t_name); ("buf", Cty_ptr Cty_char)];
|
2010-06-15 10:49:03 +02:00
|
|
|
f_body =
|
|
|
|
{ var_decls = [];
|
|
|
|
block_body =
|
|
|
|
let gen_clause t =
|
2010-09-13 13:44:26 +02:00
|
|
|
let t = cname_of_qn t in
|
2010-06-15 10:49:03 +02:00
|
|
|
let fun_call =
|
2011-05-30 10:06:16 +02:00
|
|
|
Cfun_call ("strcpy", [Cvar "buf";
|
2010-06-15 10:49:03 +02:00
|
|
|
Cconst (Cstrlit t)]) in
|
|
|
|
(t, [Csexpr fun_call]) in
|
2011-05-30 10:06:16 +02:00
|
|
|
[Cswitch (Cvar "x", map gen_clause nl);
|
|
|
|
Creturn (Cvar "buf")]; }
|
2010-06-15 10:49:03 +02:00
|
|
|
} in
|
|
|
|
([of_string_fun; to_string_fun],
|
2010-09-13 13:44:26 +02:00
|
|
|
[Cdecl_enum (name, List.map cname_of_qn nl);
|
|
|
|
cdecl_of_cfundef of_string_fun;
|
2010-06-15 10:49:03 +02:00
|
|
|
cdecl_of_cfundef to_string_fun])
|
|
|
|
| Type_struct fl ->
|
2011-09-06 14:20:57 +02:00
|
|
|
let decls = List.map (fun f -> cname_of_name f.Signature.f_name.name,
|
2010-07-13 14:03:39 +02:00
|
|
|
ctype_of_otype f.Signature.f_type) fl in
|
2010-09-13 09:37:58 +02:00
|
|
|
let decl = Cdecl_struct (name, decls) in
|
2010-06-16 11:32:13 +02:00
|
|
|
([], [decl])
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2011-09-06 11:54:03 +02:00
|
|
|
let cdefs_and_cdecls_of_const_decl cd =
|
|
|
|
let name = cname_of_qn cd.c_name in
|
|
|
|
let v = cexpr_of_static_exp cd.Obc.c_value in
|
|
|
|
let cty = ctype_of_otype cd.Obc.c_type in
|
|
|
|
[], [Cdecl_constant (name, cty, v)]
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2011-09-06 11:54:03 +02:00
|
|
|
let cdefs_and_cdecls_of_interface_decl id = match id with
|
|
|
|
| Itypedef td -> cdefs_and_cdecls_of_type_decl td
|
|
|
|
| Iconstdef cd -> cdefs_and_cdecls_of_const_decl cd
|
|
|
|
| _ -> [], []
|
2010-07-27 16:27:07 +02:00
|
|
|
|
2011-09-06 11:54:03 +02:00
|
|
|
let cdefs_and_cdecls_of_program_decl id = match id with
|
|
|
|
| Ptype td -> cdefs_and_cdecls_of_type_decl td
|
|
|
|
| Pconst cd -> cdefs_and_cdecls_of_const_decl cd
|
|
|
|
| _ -> [], []
|
2010-06-15 10:49:03 +02:00
|
|
|
|
2011-11-22 14:43:52 +01:00
|
|
|
let header_of_module m = match m with
|
|
|
|
| Module "Iostream" -> "stdio"
|
|
|
|
| _ -> String.uncapitalize (modul_to_string m)
|
|
|
|
|
2010-06-15 10:49:03 +02:00
|
|
|
let global_file_header name prog =
|
2011-03-08 09:22:02 +01:00
|
|
|
let dependencies = ModulSet.elements (Obc_utils.Deps.deps_program prog) in
|
2011-11-22 14:43:52 +01:00
|
|
|
let dependencies = List.map header_of_module dependencies in
|
2010-07-27 16:27:07 +02:00
|
|
|
|
2011-04-19 09:23:52 +02:00
|
|
|
let classes = program_classes prog in
|
2010-07-27 16:27:07 +02:00
|
|
|
let (decls, defs) =
|
2011-04-19 09:23:52 +02:00
|
|
|
List.split (List.map cdefs_and_cdecls_of_class_def classes) in
|
2010-07-27 16:27:07 +02:00
|
|
|
let decls = List.concat decls
|
|
|
|
and defs = List.concat defs in
|
|
|
|
|
2011-09-06 11:54:03 +02:00
|
|
|
let filename_types = name ^ "_types" in
|
|
|
|
let cdefs_and_cdecls = List.map cdefs_and_cdecls_of_program_decl prog.p_desc in
|
|
|
|
|
|
|
|
let (cty_defs, cty_decls) = List.split cdefs_and_cdecls in
|
|
|
|
let types_h = (filename_types ^ ".h",
|
|
|
|
Cheader ("stdbool"::"assert"::"pervasives"::dependencies,
|
|
|
|
List.concat cty_decls)) in
|
|
|
|
let types_c = (filename_types ^ ".c", Csource (concat cty_defs)) in
|
2010-07-27 16:27:07 +02:00
|
|
|
|
|
|
|
let header =
|
2011-09-06 11:54:03 +02:00
|
|
|
(name ^ ".h", Cheader (filename_types :: dependencies, decls))
|
2010-07-27 16:27:07 +02:00
|
|
|
and source =
|
|
|
|
(name ^ ".c", Csource defs) in
|
2011-09-06 11:54:03 +02:00
|
|
|
[header; source; types_h; types_c]
|
|
|
|
|
|
|
|
|
|
|
|
let interface_header name i =
|
|
|
|
let dependencies = ModulSet.elements (Obc_utils.Deps.deps_interface i) in
|
2011-11-22 14:43:52 +01:00
|
|
|
let dependencies = List.map header_of_module dependencies in
|
2011-09-06 11:54:03 +02:00
|
|
|
|
|
|
|
let cdefs_and_cdecls = List.map cdefs_and_cdecls_of_interface_decl i.i_desc in
|
|
|
|
|
|
|
|
let (cty_defs, cty_decls) = List.split cdefs_and_cdecls in
|
|
|
|
let types_h = (name ^ ".h",
|
|
|
|
Cheader ("stdbool"::"assert"::"pervasives"::dependencies,
|
|
|
|
List.concat cty_decls)) in
|
|
|
|
let types_c = (name ^ ".c", Csource (concat cty_defs)) in
|
|
|
|
|
|
|
|
[types_h; types_c]
|