Project

General

Profile

Download (5.39 KB) Statistics
| Branch: | Tag: | Revision:
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

    
12
open Utils
13
open Format
14
open Lustre_types
15
open Machine_code_types
16
open Corelang
17

    
18
let get_machine = Machine_code_common.get_machine
19

    
20
let machine_reset_name id = id ^ "_reset"
21

    
22
let machine_step_name id = id ^ "_step"
23

    
24
let machine_stateless_name id = id ^ "_fun"
25

    
26
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
27

    
28
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
29

    
30
let pp_machine_stateless_name fmt id = fprintf fmt "%s_fun" id
31

    
32
let rec pp_type fmt t =
33
  if Types.is_bool_type t then fprintf fmt "Bool"
34
  else if Types.is_int_type t then fprintf fmt "Int"
35
  else if Types.is_real_type t then fprintf fmt "Real"
36
  else
37
    match (Types.repr t).Types.tdesc with
38
    | Types.Tconst ty ->
39
      pp_print_string fmt ty
40
    | Types.Tclock t ->
41
      pp_type fmt t
42
    | Types.Tarray (_, ty) ->
43
      fprintf fmt "(Array Int ";
44
      pp_type fmt ty;
45
      fprintf fmt ")"
46
    | Types.Tstatic (_, ty) ->
47
      pp_type fmt ty
48
    | Types.Tarrow _ | _ ->
49
      eprintf "internal error: pp_type %a@." Types.print_ty t;
50
      assert false
51

    
52
let pp_decl_var fmt id =
53
  fprintf fmt "(declare-var %s %a)" id.var_id pp_type id.var_type
54

    
55
(* let pp_var fmt id = pp_print_string fmt id.var_id *)
56

    
57
let pp_conj pp fmt l =
58
  match l with
59
  | [] ->
60
    assert false
61
  | [ x ] ->
62
    pp fmt x
63
  | _ ->
64
    fprintf fmt "(and @[<v 0>%a@]@ )" (pp_print_list pp) l
65

    
66
(********************************************************************************************)
67
(* Workaround to prevent the use of declared keywords as node name *)
68
(********************************************************************************************)
69
let registered_keywords = [ "implies" ]
70

    
71
let protect_kwd s = if List.mem s registered_keywords then "__" ^ s else s
72

    
73
let node_name n =
74
  let name = node_name n in
75
  protect_kwd name
76

    
77
let concat prefix x = if prefix = "" then x else prefix ^ "." ^ x
78

    
79
let rename f v = { v with var_id = f v.var_id }
80

    
81
let rename_machine p = rename (fun n -> concat p n)
82

    
83
let rename_machine_list p = List.map (rename_machine p)
84

    
85
let rename_current = rename (fun n -> n ^ "_c")
86

    
87
let rename_current_list = List.map rename_current
88

    
89
let rename_mid = rename (fun n -> n ^ "_m")
90

    
91
let rename_mid_list = List.map rename_mid
92

    
93
let rename_next = rename (fun n -> n ^ "_x")
94

    
95
let rename_next_list = List.map rename_next
96

    
97
let local_memory_vars machine =
98
  rename_machine_list machine.mname.node_id machine.mmemory
99

    
100
let instances_memory_vars ?(without_arrow = false) machines machine =
101
  let rec aux fst prefix m =
102
    (if not fst then
103
     rename_machine_list (concat prefix m.mname.node_id) m.mmemory
104
    else [])
105
    @ List.fold_left
106
        (fun accu (id, (n, _)) ->
107
          let name = node_name n in
108
          if without_arrow && name = "_arrow" then accu
109
          else
110
            let machine_n = get_machine machines name in
111
            aux false
112
              (concat prefix (if fst then id else concat m.mname.node_id id))
113
              machine_n
114
            @ accu)
115
        [] m.minstances
116
  in
117
  aux true machine.mname.node_id machine
118

    
119
(* Extract the arrows of a given node/machine *)
120
let arrow_vars machines machine : Lustre_types.var_decl list =
121
  let rec aux fst prefix m =
122
    List.fold_left
123
      (fun accu (id, (n, _)) ->
124
        let name = node_name n in
125
        if name = "_arrow" then
126
          let arrow_machine = Machine_code_common.arrow_machine in
127
          rename_machine_list
128
            (concat prefix
129
               (concat (if fst then id else concat m.mname.node_id id) "_arrow"))
130
            arrow_machine.mmemory
131
          @ accu
132
        else
133
          let machine_n = get_machine machines name in
134
          aux false
135
            (concat prefix (if fst then id else concat m.mname.node_id id))
136
            machine_n
137
          @ accu)
138
      [] m.minstances
139
  in
140
  aux true machine.mname.node_id machine
141

    
142
let full_memory_vars ?(without_arrow = false) machines machine =
143
  local_memory_vars machine
144
  @ instances_memory_vars ~without_arrow machines machine
145

    
146
let inout_vars m =
147
  rename_machine_list m.mname.node_id m.mstep.step_inputs
148
  @ rename_machine_list m.mname.node_id m.mstep.step_outputs
149

    
150
let step_vars machines m =
151
  inout_vars m
152
  @ rename_current_list (full_memory_vars machines m)
153
  @ rename_next_list (full_memory_vars machines m)
154

    
155
let step_vars_m_x machines m =
156
  inout_vars m
157
  @ rename_mid_list (full_memory_vars machines m)
158
  @ rename_next_list (full_memory_vars machines m)
159

    
160
let reset_vars machines m =
161
  rename_current_list (full_memory_vars machines m)
162
  @ rename_mid_list (full_memory_vars machines m)
163

    
164
let step_vars_c_m_x machines m =
165
  inout_vars m
166
  @ rename_current_list (full_memory_vars machines m)
167
  @ rename_mid_list (full_memory_vars machines m)
168
  @ rename_next_list (full_memory_vars machines m)
169

    
170
(* Local Variables: *)
171
(* compile-command:"make -C ../.." *)
172
(* End: *)
(5-5/10)