Project

General

Profile

Download (9.17 KB) Statistics
| Branch: | Tag: | Revision:
1
open Vhdl_ast
2
open Vhdl_ast_pp
3
open Vhdl_2_mini_vhdl_map
4
open Mini_vhdl_utils
5

    
6
type level = INFO | WARNING | ERROR
7

    
8
let print ?(level = INFO) ?(code = "") s =
9
  match s with
10
  | "" -> ()
11
  | _ -> match level with
12
    | INFO -> Printf.printf    "<INFO> %s" s
13
    | WARNING -> Printf.printf "<WARN_%s> %s" code s
14
    | ERROR -> Printf.printf   "<ERR_%s> %s" code s
15

    
16
let separator s = 
17
  Printf.printf "----------%s----------\n" (String.make (String.length s) '-');
18
  Printf.printf "--------- %s ---------\n" s;
19
  Printf.printf "----------%s----------\n" (String.make (String.length s) '-')
20

    
21
let filter_display s l to_string_name = match l with
22
  | [] -> ""
23
  | _ -> Printf.sprintf "%s [%s]\n" s (String.concat ", " (List.map to_string_name l))
24

    
25
(**
26
 * Display
27
 *)
28
let display_struct_content : (vhdl_name_t -> string) -> db_tuple_t -> unit =
29
  fun to_string_name ->
30
    fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; memories; contexts} ->
31
      let arch_name = to_string_name architecture.a_name in
32
      let ent_name = to_string_name entity.e_name in
33
      let sigs_names = List.flatten (List.map mini_vhdl_declaration_t_names architecture_signals) in
34
      let in_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InPort)) in
35
      let out_ports_names = List.flatten (List.map get_names (get_ports architecture_ports OutPort)) in
36
      let inout_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InoutPort)) in
37
      let generics_names = List.flatten (List.map get_names architecture_generics) in
38
      print (Printf.sprintf "Details for architecture [%s] of entity [%s]\n" arch_name ent_name);
39
      print (filter_display "  Inner signals" sigs_names to_string_name);
40
      print (filter_display "  In ports" in_ports_names to_string_name);
41
      print (filter_display "  InOut ports" inout_ports_names to_string_name);
42
      print (filter_display "  Out ports" out_ports_names to_string_name);
43
      print (filter_display "  Generics" generics_names to_string_name);
44
      print (filter_display "  Assigned names" (List.sort_uniq compare assigned_signals_names) to_string_name);
45
      print (filter_display "  Memories" (List.sort_uniq compare memories) to_string_name)
46

    
47
(**
48
 * Checks
49
 * All checks should have the same signature:
50
 *  (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit
51
 *)
52
let check_error_duplicate_signal_assignment : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=
53
  fun to_string_name -> fun code -> fun level ->
54
      fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->
55
        let dupl = duplicates assigned_signals_names in
56
        if List.length dupl > 0
57
          then print ~level:level ~code:code (Printf.sprintf " Duplicate concurrent assignment of %s" (filter_display "signal" dupl to_string_name))
58
          else ()
59

    
60
let check_missing_signal_assignment : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=
61
  fun to_string_name -> fun code -> fun level ->
62
      fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->
63
        let out_ports_names = List.flatten (List.map get_names (get_ports architecture_ports OutPort)) in
64
        let inout_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InoutPort)) in
65
        let sigs_names = List.flatten (List.map mini_vhdl_declaration_t_names architecture_signals) in
66
        let declared_signals = inout_ports_names@sigs_names@out_ports_names in
67
        let uniq_assigned_signals = List.sort_uniq compare assigned_signals_names in
68
        let missing = diff declared_signals uniq_assigned_signals in
69
        if List.length missing > 0
70
          then print ~level:level ~code:code (Printf.sprintf " Missing assignment of %s" (filter_display "signal" missing to_string_name))
71
          else ()
72

    
73
(* let count_architecture : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=
74
  fun to_string_name -> fun code -> fun level ->
75
      fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->
76
        let count (e : vhdl_architecture_t) : (int * int) =
77
          let visitor = object
78
            val mutable count_sig = 0
79
            val mutable count_var = 0
80
            method count_sig = count_sig
81
            method count_var = count_var
82
            inherit [_] vhdl_iter as super
83
            method! visit_vhdl_declaration_t env d =
84
              match d with
85
              | SigDecl n -> count_sig <- count_sig + (List.length n.names);
86
              | VarDecl n -> count_var <- count_var + (List.length n.names);
87
              | _ -> ();
88
              super#visit_vhdl_declaration_t env d
89
            end
90
          in
91
          visitor#visit_vhdl_architecture_t () e;
92
          (visitor#count_sig, visitor#count_var) in
93
        let (nb_sig, nb_var) = (count architecture) in
94
        print ~level:level ~code:code (Printf.sprintf "  Nb signals declarations in archi %s : %d\n" (to_string_name architecture.a_name) nb_sig);
95
        print ~level:level ~code:code (Printf.sprintf "  Nb variables declarations in archi %s : %d\n" (to_string_name architecture.a_name) nb_var) *)
96

    
97
let latches_detection : (vhdl_name_t -> string) -> string -> level -> db_tuple_t -> unit=
98
  fun to_string_name -> fun code -> fun level ->
99
      fun {entity; architecture; architecture_signals; architecture_ports; architecture_generics; assigned_signals_names; contexts} ->
100

    
101
(*        
102
        let in_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InPort)) in
103
        let out_ports_names = List.flatten (List.map get_names (get_ports architecture_ports OutPort)) in
104
        let inout_ports_names = List.flatten (List.map get_names (get_ports architecture_ports InoutPort)) in
105
        let sigs_names = List.flatten (List.map mini_vhdl_declaration_t_names architecture_signals) in
106
        let arch_writable_signals = inout_ports_names@sigs_names@out_ports_names in
107
        let arch_readable_signals = inout_ports_names@sigs_names@in_ports_names in
108
*)
109
        
110
        let get_latched_processes (arch : vhdl_architecture_t) : (vhdl_process_t * vhdl_sequential_stmt_t) list =
111
          let visitor = object (self)
112
            val mutable current_process = []
113
            val mutable latched_processes = []
114
            method current_process = current_process
115
            method latched_processes = latched_processes
116
            
117
            inherit [_] vhdl_iter as super_vhdl
118
          
119
            method! visit_vhdl_process_t env p =
120
              current_process <- [p];
121
              List.iter (super_vhdl#visit_vhdl_sequential_stmt_t env) p.p_body
122

    
123
            method! visit_vhdl_sequential_stmt_t env s =
124
              match s with
125
              | If ({label; if_cases; default}) -> 
126
                  (match default with 
127
                  | [] -> latched_processes <- ((List.hd current_process), s)::latched_processes;
128
                  | _ -> ();
129
                  (match if_cases with
130
                  | [] -> () 
131
                  | _ -> 
132
                      let sub_seq_stmts = List.flatten (List.map (function x -> x.if_block) if_cases) in
133
                      List.iter (self#visit_vhdl_sequential_stmt_t env) sub_seq_stmts))
134
              | Case ({label; guard; branches}) ->
135
                  let cond_exprs = guard::(List.flatten (List.map (function x -> x.when_cond) branches)) in
136
                  let sub_seq_stmts = List.flatten (List.map (function x -> x.when_stmt) branches) in
137
                  let has_others = List.exists (function c -> match c with | Others -> true | _ -> false) cond_exprs in
138
                  (* TODO: Needs something like: is_exhaustive_mapping cond_exprs *) (*let is_exhaustive_mapping = false in*)
139
                  if (not (has_others)) then (* Add test for is_exhaustive_mapping *)
140
                    latched_processes <- ((List.hd current_process), s)::latched_processes;
141
                  List.iter (self#visit_vhdl_sequential_stmt_t env) sub_seq_stmts
142
              | _ -> super_vhdl#visit_vhdl_sequential_stmt_t env s
143
            end
144
          in
145
          visitor#visit_vhdl_architecture_t () arch;
146
          visitor#latched_processes in
147
        List.iter (function (p,s) -> 
148
          print ~level:level ~code:code (
149
            Printf.sprintf "  Potentially latched process [%s] in architecture [%s]. See statement: \n%s\n"
150
              (to_string_name p.id)
151
              (to_string_name architecture.a_name)
152
              (show_vhdl_sequential_stmt_t s)
153
            )
154
          ) (get_latched_processes architecture)
155

    
156
let checks = [
157
  ("#E001",ERROR,check_error_duplicate_signal_assignment);
158
  ("#W001",WARNING,check_missing_signal_assignment);
159
  ("#W002",WARNING,latches_detection)
160
(*  ("#I001",INFO,count_architecture)*)
161
]
162

    
163
(**
164
 * Main
165
 *)
166
let check_mini_vhdl db to_string_name =
167
  let rec iter_checks checks x = match checks with
168
    | [] -> ()
169
    | (code,level,check)::tl -> check to_string_name code level x; iter_checks tl x in
170
  let disp_and_check x =
171
    separator "Structure";
172
    display_struct_content to_string_name x;
173
    separator "Checks";
174
    iter_checks checks x in
175
  List.iter disp_and_check db;
(2-2/3)