package fsml

  1. Overview
  2. Docs

Source file vhdl.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
(**********************************************************************)
(*                                                                    *)
(*              This file is part of the FSML library                 *)
(*                     github.com/jserot/fsml                         *)
(*                                                                    *)
(*  Copyright (c) 2020-present, Jocelyn SEROT.  All rights reserved.  *)
(*                                                                    *)
(*  This source code is licensed under the license found in the       *)
(*  LICENSE file in the root directory of this source tree.           *)
(*                                                                    *)
(**********************************************************************)

(* VHDL backend *)

open Printf

exception Error of string * string  (* where, msg *)

type config = {
  mutable state_var: string;
  mutable reset_sig: string;
  mutable clk_sig: string;
  mutable use_numeric_std: bool;
  mutable act_sem: act_semantics;
  }

and act_semantics =  (** Interpretation of actions associated to transitions *)
  | Sequential        (** sequential (ex: [x:=x+1,y:=x] with [x=1] gives [x=2,y=2]) *)
  | Synchronous       (** synchronous (ex: [x:=x+1,y=x] with [x=1] gives [x=2,y=1]) *)

let cfg = {
  state_var = "state";
  reset_sig = "rst";
  clk_sig = "clk";
  use_numeric_std = false;
  act_sem = Sequential;
    (* Note. This is to make OCaml, C and VHDL behaviors observationaly equivalent. 
       Synchronous behavior is implemented (and can be selected) but potentially
       breaks this equivalence because it is not (yet) implemented at the OCaml and
       C level. *)
  }

type vhdl_type = 
  | Unsigned of int
  | Signed of int
  | Integer of int_range option
  | Std_logic

and int_range = int * int (* lo, hi *)             

let vhdl_type_of t =
  let open Types in
  match t with 
  | TyBool -> Std_logic
  | TyInt (sg, SzConst sz) ->
     begin match Types.real_type sg, cfg.use_numeric_std with
     | TyUnsigned, true -> Unsigned sz
     | TyUnsigned, false -> Integer (Some (0, Misc.pow2 sz - 1))
     | _, true -> Signed sz
     | _, false -> Integer (Some (-Misc.pow2 (sz-1), Misc.pow2 (sz-1) - 1))
     end
  | TyInt (_, _) -> Integer None
  | _ -> failwith ("VHDL backend: illegal type: " ^ Types.to_string t)

type type_mark = TM_Full | TM_Abbr | TM_None [@@warning "-37"]
                                   
let string_of_vhdl_type ?(type_marks=TM_Full) t = match t, type_marks with 
  | Unsigned n, TM_Full -> Printf.sprintf "unsigned(%d downto 0)" (n-1)
  | Unsigned n, TM_Abbr -> Printf.sprintf "unsigned%d" n
  | Unsigned _, TM_None -> "unsigned"
  | Signed n, TM_Full -> Printf.sprintf "signed(%d downto 0)" (n-1)
  | Signed n, TM_Abbr -> Printf.sprintf "signed%d" n
  | Signed _, TM_None -> "signed"
  | Integer (Some (lo,hi)), TM_Full -> Printf.sprintf "integer range %d to %d" lo hi
  | Integer _, _ -> "integer"
  | Std_logic, _ -> "std_logic"

let string_of_type ?(type_marks=TM_Full) t =
  string_of_vhdl_type ~type_marks:type_marks (vhdl_type_of t)

let string_of_op = function
  | "!=" -> " /= "
  | op ->  op

let string_of_expr e =
  let paren level s = if level > 0 then "(" ^ s ^ ")" else s in
  let rec string_of level e =
    match e.Expr.e_desc, vhdl_type_of (e.Expr.e_typ)  with
    | Expr.EInt n, Unsigned s -> Printf.sprintf "to_unsigned(%d,%d)" n s
    | Expr.EInt n, Signed s -> Printf.sprintf "to_signed(%d,%d)" n s
    | Expr.EInt n, _ -> string_of_int n
    | Expr.EBool b, _ -> if b then "'1'" else "'0'"
    | Expr.EVar n, _ ->  n
    | Expr.EBinop (op,e1,e2), ty -> 
       let s1 = string_of (level+1) e1 
       and s2 = string_of (level+1) e2 in 
       begin match op, ty with
       | "*", Signed _
       | "*", Unsigned _ -> "mul(" ^ s1 ^ "," ^ s2 ^ ")"
       | _, _ -> paren level (s1 ^ string_of_op op ^ s2)
       end
  in
  string_of 0 e

(* and string_of_int_expr e = match e.Expr.e_desc, vhdl_type_of (e.Expr.e_typ) with
 *     Expr.EInt n, _ -> string_of_int n
 *   | _, Integer _ -> string_of_expr e
 *   | _, _ -> "to_integer(" ^ string_of_expr e ^ ")"
 * 
 * and string_of_range id hi lo = id ^ "(" ^ string_of_int_expr hi ^ " downto " ^ string_of_int_expr lo ^ ")" *)

let string_of_action m a =
  let open Seqmodel in
  let asn id = if List.mem_assoc id m.m_vars && cfg.act_sem = Sequential then " := " else " <= " in
  match a with
  | Action.Assign (id, expr) ->
     id ^ asn id ^ string_of_expr expr

let string_of_guards gs =  
  Misc.string_of_list ~f:string_of_expr ~sep:" and " gs

let dump_action oc tab m a = fprintf oc "%s%s;\n" tab (string_of_action m a)

let dump_transition oc tab src m (is_first,_) (_,guards,acts,dst) =
  match guards with
    [] -> 
       List.iter (dump_action oc tab m) acts;
       fprintf oc "%s%s <= %s;\n" tab cfg.state_var dst;
       (false,false)
  | _ ->
       fprintf oc "%s%s ( %s ) then\n" tab (if is_first then "if" else "elsif ") (string_of_guards guards);
       List.iter (dump_action oc (tab ^ "  ") m) acts;
       if dst <> src then fprintf oc "%s  %s <= %s;\n" tab cfg.state_var dst;
       (false,true)

let dump_sync_transitions oc src _ m ts =
   let tab = "        " in
   let (_,needs_endif) = List.fold_left (dump_transition oc tab src m) (true,false) ts in
   if needs_endif then fprintf oc "        end if;\n"
     
let dump_state oc m (src,tss) =
  match tss with
  | [] -> raise (Error (m.Seqmodel.m_name, "VHDL: state " ^ src ^ " has no output transition"))
  | _ -> dump_sync_transitions oc src false m tss

let dump_state_case oc m (src, tss) =
    fprintf oc "      when %s =>\n" src;
    dump_state oc m (src,tss)

let dump_module_arch oc m =
  let open Seqmodel in
  let modname = m.m_name in
  fprintf oc "architecture RTL of %s is\n" modname;
  fprintf oc "  type t_%s is ( %s );\n" cfg.state_var (Misc.string_of_list ~f:Fun.id ~sep:", " m.m_states);
  fprintf oc "  signal %s: t_state;\n" cfg.state_var;
  if cfg.act_sem = Synchronous then 
    List.iter
      (fun (id,ty) -> fprintf oc "  signal %s: %s;\n" id (string_of_type ~type_marks:TM_Abbr ty))
      m.m_vars;
  fprintf oc "begin\n";
  fprintf oc "  process(%s, %s)\n" cfg.reset_sig cfg.clk_sig;
  if cfg.act_sem = Sequential then 
    List.iter
      (fun (id,ty) -> fprintf oc "    variable %s: %s;\n" id (string_of_type ty))
      m.m_vars;
  fprintf oc "  begin\n";
  fprintf oc "    if ( %s='1' ) then\n" cfg.reset_sig;
  fprintf oc "      %s <= %s;\n" cfg.state_var (fst m.m_init);
  List.iter (dump_action oc "      " m) (snd m.m_init);
  fprintf oc "    elsif rising_edge(%s) then \n" cfg.clk_sig;
  begin match m.m_body with
    [] -> () (* should not happen *)
  | [c] -> dump_state oc m c 
  | _ -> 
      fprintf oc "      case %s is\n" cfg.state_var;
      List.iter (dump_state_case oc m) m.m_body;
      fprintf oc "    end case;\n"
  end;
  fprintf oc "    end if;\n";
  fprintf oc "  end process;\n";
  fprintf oc "end architecture;\n"

let dump_module_intf kind oc m = 
  let open Seqmodel in
  let modname = m.m_name in
  fprintf oc "%s %s %s\n" kind modname (if kind = "entity" then "is" else "");
  fprintf oc "  port(\n";
  List.iter (fun (id,ty) -> fprintf oc "        %s: in %s;\n" id (string_of_type ty)) m.m_inps;
  List.iter (fun (id,ty) -> fprintf oc "        %s: out %s;\n" id (string_of_type ty)) m.m_outps;
  fprintf oc "        %s: in std_logic;\n" cfg.clk_sig;
  fprintf oc "        %s: in std_logic\n);\n" cfg.reset_sig;
  fprintf oc "end %s;\n" kind

let dump_model fname m =
  let oc = open_out fname in
  fprintf oc "library ieee;\n";
  fprintf oc "use ieee.std_logic_1164.all;\n";
  if cfg.use_numeric_std then fprintf oc "use ieee.numeric_std.all;\n";
  (* fprintf oc "library %s;\n" cfg.support_library;
   * fprintf oc "use %s.%s.all;\n" cfg.support_library cfg.support_package; *)
  fprintf oc "\n";
  dump_module_intf "entity" oc m;
  fprintf oc "\n";
  dump_module_arch oc m;
  printf "Wrote file %s\n" fname;
  close_out oc

let write ?(dir="") ~prefix f = 
  let m = Seqmodel.make f in
  let () = Misc.check_dir dir in
  let p = dir ^ Filename.dir_sep ^ prefix in
  dump_model (p ^ ".vhd") m
OCaml

Innovation. Community. Security.