Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / VHDL / mini_vhdl_ast_transform.ml @ 12946cbe

History | View | Annotate | Download (5.43 KB)

1
open Vhdl_ast
2
open Vhdl_ast_utils
3
open Vhdl_ast_transform
4
open Mini_vhdl_ast
5
open Mini_vhdl_ast_pp
6

    
7
(* Generate wait on statement in processes and empty sensitivity list *)
8
(* TODO: add support for "all" construct *)
9
let generate_wait_stmt_for_sensible_processes = object (self)
10
  inherit [_] mini_vhdl_map as super
11

    
12
  method! visit_mini_vhdl_process_t env proc =
13
    match proc.active_sigs with
14
    | [] -> proc
15
    | _ ->
16
        let new_wait = MiniWait { sensitivity = proc.active_sigs } in
17
        {
18
          id = proc.id;
19
          p_declarations = proc.p_declarations;
20
          active_sigs = [];
21
          p_body = proc.p_body@[new_wait];
22
          postponed = proc.postponed;
23
          label = proc.label
24
        }
25
end
26

    
27
(* Flatten components instantiation *)
28
let flatten_components_instantiations = object (self)
29
  inherit [_] mini_vhdl_map as super
30

    
31
  val mutable components = [];
32
  
33
  method! visit_mini_vhdl_design_file_t env df =
34
    components <- df.components;
35
    let flattened_comps =  List.map (self#visit_mini_vhdl_component_t env) components in
36
    { components = flattened_comps;
37
      packages = df.packages }
38
  
39
  method mini_vhdl_comp_inst_to_comp inst =
40
    { names = [inst.ci_name];
41
      generics = [];
42
      ports = [];
43
      contexts = [];
44
      c_declarations = [];
45
      definitions = [];
46
      c_body = [];
47
      sub_components = [] }
48

    
49
  method prefix_mini_vhdl_conc_stmt_t: string -> mini_vhdl_concurrent_stmt_t -> mini_vhdl_concurrent_stmt_t=
50
    fun pre -> fun conc ->
51
    match conc with
52
    | MiniProcess (a) -> MiniProcess (self#prefix_mini_vhdl_process_t pre a)
53
    | MiniComponentInst (a) ->
54
      failwith ("Component instantiation shall have been flattened at this point: " ^ to_string_vhdl_name_t (flatten_vhdl_name_t a.ci_name))
55
    
56
  method prefix_mini_vhdl_process_t: string -> mini_vhdl_process_t -> mini_vhdl_process_t =
57
    fun pre -> fun {id; p_declarations; active_sigs; p_body; postponed; label} ->
58
    let id = prefix_flatten_vhdl_name_t pre id in
59
    {id; p_declarations; active_sigs; p_body; postponed; label}
60
    
61
  method! visit_mini_vhdl_component_t env comp =
62
    let is_component_inst x =  match x with | MiniProcess (a) -> false | MiniComponentInst (a) -> true in
63
    let comp_inst_components = List.filter is_component_inst comp.c_body in
64
    List.iter print_string (List.map show_mini_vhdl_concurrent_stmt_t comp_inst_components);
65
    
66
    let get_instantiated_component lst x = match x with
67
      | MiniProcess (a) -> lst
68
      | MiniComponentInst (a) -> (List.filter (fun x -> x.names = [a.archi.a_name; a.entity.e_name]) components)@lst in
69

    
70
    let instantiated_components = List.fold_left get_instantiated_component [] comp_inst_components in
71
    (* Recursive call to inline instantiated components *)
72
    let instantiated_components = List.map (self#visit_mini_vhdl_component_t env) instantiated_components in
73
    (* Get instantiated components body *)
74
    let inner_conc_stmts = List.flatten (
75
        List.map ( fun x -> (
76
              List.map (
77
                (* Prefix concurrent stmt name with instantiated component name *)
78
                self#prefix_mini_vhdl_conc_stmt_t (String.concat "__" (List.map to_string_vhdl_name_t x.names))
79
              ) x.c_body )
80
        ) instantiated_components) in
81

    
82
    (* Copy inst component content to parent component content *)
83
    let contexts = comp.contexts @ (List.flatten (List.map (fun x -> x.contexts) instantiated_components )) in
84
    let uniq_elem x lst = if (List.mem x lst) then lst else x::lst in
85
    let contexts = List.fold_right uniq_elem contexts [] in
86
    let c_declarations = comp.c_declarations @ (List.flatten (List.map (fun x -> x.c_declarations) instantiated_components )) in
87
    let definitions = comp.definitions @ (List.flatten (List.map (fun x -> x.definitions) instantiated_components )) in
88
    let c_body = comp.c_body @ inner_conc_stmts in 
89
    
90
    { names = comp.names; generics = comp.generics; ports = comp.ports; 
91
      contexts; c_declarations; definitions; c_body; sub_components = comp.sub_components }
92
end
93

    
94
(* Signals lattice *)
95
type lattice_proc_element =
96
  {
97
    proc : mini_vhdl_process_t;
98
    assigned_signals : vhdl_name_t list;
99
    sensible_signals : vhdl_name_t list;
100
  }
101
and lattice_component_element =
102
  {
103
    comp : mini_vhdl_component_t;
104
    sub_components : mini_vhdl_component_t list;
105
    processes : lattice_proc_element list;
106
  }
107

    
108
let build_signals_lattice = object (self)
109
  inherit [_] mini_vhdl_iter as super
110

    
111
  val mutable assigned_signals = []
112
  val mutable sensible_signals = []
113
  val mutable lattice = []
114
  method assigned_signals = assigned_signals
115
  method sensible_signals = sensible_signals
116
  method lattice = lattice
117

    
118
  method! visit_mini_vhdl_process_t env proc =
119
    (* TODO do we need to handle internal signals declared in p_declarations ? *)
120
    assigned_signals <- [];
121
    sensible_signals <- [];
122
    super#visit_mini_vhdl_process_t env proc;
123
    lattice <- lattice@[{ proc; assigned_signals; sensible_signals}]; ()
124

    
125
  method! visit_mini_vhdl_sequential_stmt_t env s =
126
    match s with
127
    | MiniWait ({ sensitivity }) -> sensible_signals <- sensible_signals@sensitivity
128
    | MiniSigSeqAssign ({ label; lhs; rhs }) -> assigned_signals <- assigned_signals@[lhs]
129
    | MiniSigCondAssign ({ label; lhs; rhs; delay }) -> assigned_signals <- assigned_signals@[lhs]
130
    | MiniSigSelectAssign ({ label; lhs; sel; branches; delay }) -> assigned_signals <- assigned_signals@[lhs]
131
    (* TODO Manage procedure calls *)
132
    | _ -> super#visit_mini_vhdl_sequential_stmt_t env s
133

    
134
end
135

    
136