--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | MIT License
2 |
3 | Copyright (c) 2020-now Jocelyn SEROT (jocelyn.serot@uca.fr)
4 |
5 | Permission is hereby granted, free of charge, to any person obtaining a copy
6 | of this software and associated documentation files (the "Software"), to deal
7 | in the Software without restriction, including without limitation the rights
8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9 | copies of the Software, and to permit persons to whom the Software is
10 | furnished to do so, subject to the following conditions:
11 |
12 | The above copyright notice and this permission notice shall be included in all
13 | copies or substantial portions of the Software.
14 |
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21 | SOFTWARE.
22 |
--------------------------------------------------------------------------------
/examples/ex4/test.ml:
--------------------------------------------------------------------------------
1 | (* This example shows how to define parameterized FSM builders.
2 | Here, [genimp n] has the same behavior of the [gensig] FSM defined in [../ex2] but uses
3 | [n] states instead of a local variable.
4 | Note the use of the [fsm_trans] and [fsm_action] PPXs. *)
5 |
6 | open Fsml
7 | open Fsm
8 |
9 | let list_make f lo hi =
10 | (* [list_make f lo hi] is [[f lo; f (lo+1); ...; f hi]] *)
11 | let rec mk i = if i <= hi then f i :: mk (i+1) else [] in
12 | mk lo
13 |
14 | let genimp n =
15 | let mk_state i = "E" ^ string_of_int i in
16 | let mk_attr_state i = mk_state i, [] in
17 | let mk_trans i = (mk_state i, [], [], mk_state (i+1)) in
18 | {
19 | id="gensig";
20 | states=("E0",[]) :: list_make mk_attr_state 1 n;
21 | itrans="E0", [[%fsm_action "s:='0'"]];
22 | inps=["start", Types.TyBool];
23 | outps=["s", Types.TyBool];
24 | vars=[]; (* No local var here *)
25 | trans=
26 | [ [%fsm_trans "E0 -> E1 when start='1' with s:='1'"];
27 | (mk_state n, [], [[%fsm_action "s:='0'"]], "E0") ]
28 | @ list_make mk_trans 1 (n-1);
29 | }
30 |
31 | let f = genimp 4
32 |
33 | let _ = Dot.view f
34 |
--------------------------------------------------------------------------------
/docs/fsml/Fsml/Builtins/index.html:
--------------------------------------------------------------------------------
1 |
2 | Builtins (fsml.Fsml.Builtins)
view m evs views a simulation result for FSM m by first writing a .vcd file and then launching a VCD viewer application. The name of the output file and of the viewer application can be changed using the fname and cmd optional arguments. Returns the issued command exit status.
--------------------------------------------------------------------------------
/src/lib/valuation.ml:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | type name = string
14 | [@@deriving show {with_path=false}, yojson]
15 |
16 | type value = Expr.t
17 | [@@deriving show {with_path=false}, yojson]
18 |
19 | type t = (name * value) list (* A simple implementation using association list *)
20 | [@@deriving show {with_path=false}, yojson]
21 |
22 | let empty = []
23 |
24 | exception Duplicate of name
25 |
26 | let add n v vs = if List.mem_assoc n vs then raise (Duplicate n) else (n,v)::vs
27 |
28 | let remove n vs = List.remove_assoc n vs
29 |
30 | let mem n vs = List.mem_assoc n vs
31 |
32 | let assoc n vs = List.assoc n vs
33 |
34 | let compare vs1 vs2 =
35 | let module S = Set.Make (struct type t = name * value let compare = Stdlib.compare end) in
36 | S.compare (S.of_list vs1) (S.of_list vs2)
37 |
38 | let to_string vs = Misc.string_of_list ~f:(function (n,v) -> n ^ "=" ^ Expr.to_string v) ~sep:"," vs
39 |
40 | exception Invalid_valuation of t
41 |
42 | let names_of v = List.map fst v
43 |
44 | let check names v =
45 | let module S = Set.Make (struct type t = string let compare = Stdlib.compare end) in
46 | if not (S.equal (S.of_list names) (S.of_list (names_of v))) then raise (Invalid_valuation v)
47 |
48 |
--------------------------------------------------------------------------------
/docs/fsml/Fsml/Event/index.html:
--------------------------------------------------------------------------------
1 |
2 | Event (fsml.Fsml.Event)
--------------------------------------------------------------------------------
/src/lib/tevents.mli:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | (** {1 Timed event sets} *)
14 |
15 | type t = Event.t list Clock.clocked
16 | [@@deriving show {with_path=false}]
17 | (** A timed event set (TES) is a list of events occuring at a given clock cycle.
18 | Example [4, [x:=1,y:=1]] means that both [x] and [y] take value [1] at clock cycle 4.
19 | TES are used by simulator both to represent {i input stimuli} and {i output events} *)
20 |
21 | module Ops : sig
22 | val ( @@@ ): t list -> t list -> t list
23 | (** The [@@@] infix operator merges two sequences of TES wrt. clock cycles.
24 | Ex: [[(0,[x:=1]); (2;[x:=0])] @@@ [(1,[y:=1]); (2;y:=0)]] gives [[(0,[x:=1]); (1,[y:=1]); (2,[x:=0;y:=0])]]. *)
25 | end
26 |
27 | val merge: t list list -> t list
28 | (** [merge [st1; ...: stn]] merges n sequences of TES wrt. clock cycles.
29 | In other words, [merge [l1; l2; ...; ln]] is [l1 @@@ l2 @@@ ... @@@ ln]. *)
30 |
31 | (** {2 Wrappers} *)
32 |
33 | val changes: string -> (Expr.e_val Clock.clocked) list -> t list
34 | (** [changes name vcs] builds a list of TES from a list [vcs] of {i value changes} related to signal
35 | [name], a value change being a pair of the clk cycle and a value.
36 | Ex: [changes "x" [0,Int 1; 2,Int 0]] is [[0,[x:=1]; 2,[x:=0]]]. *)
37 |
38 | (** {2 Printing} *)
39 |
40 | val to_string: t -> string
41 |
--------------------------------------------------------------------------------
/docs/fsml/Fsml/Vcd/index.html:
--------------------------------------------------------------------------------
1 |
2 | Vcd (fsml.Fsml.Vcd)
Module Fsml.Vcd
VCD output
val write : fname:string->fsm:Fsm.t->Tevents.t list-> unit
write ~fname:file ~fsm:f evs writes a representation of a list of timed events sets evs, for FSM f in VCD (Value Change Dump) format in file file.
val view : ?fname:string->?cmd:string->fsm:Fsm.t->Tevents.t list-> int
view m evs views a simulation result for FSM m by first writing a .vcd file and then launching a VCD viewer application. The name of the output file and of the viewer application can be changed using the fname and cmd optional arguments. Returns the issued command exit status.
--------------------------------------------------------------------------------
/src/lib/c.mli:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | (** {1 C backend} *)
14 |
15 | type config = {
16 | mutable state_var: string; (** Name of variable storing the current state (default: [state]) *)
17 | mutable incl_file: string (** Name of the support include file (default: [fsml.h] *)
18 | }
19 |
20 | val cfg: config
21 |
22 | exception Error of string * string (* where, message *)
23 |
24 | val write: ?dir:string -> prefix:string -> Fsm.t -> unit
25 | (** [write prefix m] writes in files [prefix.h] and [prefix.c] a representation of FSM [m] as a C function.
26 | This function has prototype [void fsm_xxx(ctx_t *ctx)], where [xxx] is [m.m_id] and [ctx_t] is the
27 | type of a structure recording the value of inputs and outputs of the machine.
28 | Each call to the [fsm_xxx] function will correspond to one execution step of the machine: it
29 | first looks for a fireable transition (depending on the values of the inputs read in the context [ctx]
30 | and of the local variables) and, if found, performs the action associated to this transition (updating
31 | the value of outputs and local variables) and updates the current state.
32 | The generated files are written in the current working directory unless a target directory is specified
33 | with the [dir] argument. If the target directory does not exist, an attempt is made to create it. *)
34 |
--------------------------------------------------------------------------------
/src/lib/parse.ml:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | exception Error of int * int * string * string (* Line, column, token, message *)
14 |
15 | (* let report_error s lexbuf msg =
16 | * let open Lexing in
17 | * let loc_line offset l =
18 | * let m = Bytes.make (String.length l) '.' in
19 | * Bytes.set m offset '^';
20 | * Bytes.to_string m in
21 | * let pos = lexbuf.lex_curr_p in
22 | * let l =
23 | * try s |> String.split_on_char '\n' |> Fun.flip List.nth (pos.pos_lnum-1)
24 | * with Invalid_argument _ -> s in
25 | * let offset = pos.pos_cnum - pos.pos_bol - 1 in
26 | * Printf.printf "%s\n%s^\n%s" l (loc_line offset l) msg *)
27 |
28 | let error lexbuf msg =
29 | let open Lexing in
30 | let pos = lexbuf.lex_curr_p in
31 | raise (Error( pos.pos_lnum-1, pos.pos_cnum-pos.pos_bol-1, Lexing.lexeme lexbuf, msg))
32 |
33 | let parse f s =
34 | let lexbuf = Lexing.from_string s in
35 | try
36 | lexbuf |> f Fsm_lexer.main
37 | with
38 | | Fsm_lexer.Illegal_character (_, _) -> error lexbuf "Illegal character"
39 | | Fsm_parser.Error -> error lexbuf "Syntax error"
40 |
41 | let guard = parse Fsm_parser.guard_top
42 | let guards = parse Fsm_parser.guards_top
43 | let action = parse Fsm_parser.action_top
44 | let actions = parse Fsm_parser.actions_top
45 | let transition = parse Fsm_parser.transition_top
46 | let stimuli = parse Fsm_parser.stimuli
47 | let fsm = parse Fsm_parser.fsm
48 |
--------------------------------------------------------------------------------
/src/lib/ppxs.ml:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | open Ppxlib
14 | open Fsml
15 |
16 | let expand parser_name parser_fn ~loc ~path:_ (s:_) =
17 | let _ =
18 | try parser_fn s
19 | with Parse.Error (line,_,tok,msg) ->
20 | if line = -1 then (* No location *)
21 | Location.raise_errorf ~loc "%s " msg
22 | else
23 | Location.raise_errorf ~loc "%s at line %d near token \"%s\"" msg (loc.loc_start.pos_lnum+line) tok in
24 | let f = Ast_builder.Default.evar ~loc parser_name in
25 | let e = Ast_builder.Default.estring ~loc s in
26 | [%expr [%e f] [%e e]]
27 |
28 | let mk_ext ext_name parser_name parser_fn =
29 | Extension.declare
30 | ext_name
31 | Extension.Context.expression
32 | Ast_pattern.(single_expr_payload (estring __))
33 | (expand parser_name parser_fn)
34 |
35 | let () = Ppxlib.Driver.register_transformation "fsm_guard" ~extensions:[mk_ext "fsm_guard" "Parse.guard" Parse.guard]
36 | let () = Ppxlib.Driver.register_transformation "fsm_guards" ~extensions:[mk_ext "fsm_guards" "Parse.guards" Parse.guards]
37 | let () = Ppxlib.Driver.register_transformation "fsm_action" ~extensions:[mk_ext "fsm_action" "Parse.action" Parse.action]
38 | let () = Ppxlib.Driver.register_transformation "fsm_actions" ~extensions:[mk_ext "fsm_actions" "Parse.actions" Parse.actions]
39 | let () = Ppxlib.Driver.register_transformation "fsm_trans" ~extensions:[mk_ext "fsm_trans" "Parse.transition" Parse.transition]
40 | let () = Ppxlib.Driver.register_transformation "fsm" ~extensions:[mk_ext "fsm" "Parse.fsm" Parse.fsm]
41 | let () = Ppxlib.Driver.register_transformation "fsm_stim" ~extensions:[mk_ext "fsm_stim" "Parse.stimuli" Parse.stimuli]
42 |
--------------------------------------------------------------------------------
/src/lib/misc.ml:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | let string_of_list ~f ~sep l =
14 | let rec h = function
15 | [] -> ""
16 | | [x] -> f x
17 | | x::xs -> f x ^ sep ^ h xs in
18 | h l
19 |
20 | let iter_fst f l =
21 | ignore (List.fold_left (fun z x -> f z x; false) true l)
22 |
23 | let list_make ~f ~lo ~hi =
24 | let rec mk i =
25 | if i <= hi then f i :: mk (i+1)
26 | else [] in
27 | mk lo
28 |
29 |
30 | let flat_map f l = List.concat (List.map f l)
31 |
32 | let cart_prod l1 l2 =
33 | let prod p l1 l2 = flat_map (function e1 -> List.map (p e1) l2) l1 in
34 | prod (fun x y -> x,y) l1 l2
35 |
36 | let list_parse ~parse_item ~sep s =
37 | let rec parse s =
38 | match Stream.peek s with
39 | | Some _ ->
40 | let e = parse_item s in
41 | let es = parse_aux s in
42 | e::es
43 | | None ->
44 | []
45 | and parse_aux s =
46 | match Stream.peek s with
47 | | Some (Genlex.Kwd sep') when sep=sep' ->
48 | Stream.junk s;
49 | parse s
50 | | _ ->
51 | [] in
52 | parse s
53 |
54 | let string_of_opt f = function
55 | | None -> ""
56 | | Some x -> f x
57 |
58 | let rec bit_size n = if n=0 then 0 else 1 + bit_size (n/2)
59 |
60 | let rec pow2 k = if k = 0 then 1 else 2 * pow2 (k-1)
61 |
62 | let quote_string s = "\"" ^ s ^ "\""
63 |
64 | let check_dir path =
65 | if not (Sys.file_exists path && Sys.is_directory path)
66 | then Unix.mkdir path 0o777
67 |
68 | let spaces n = String.make n ' '
69 |
70 | let replace_assoc k v l =
71 | let rec scan = function
72 | [] -> []
73 | | (k',v')::rest -> if k = k' then (k,v)::scan rest else (k',v')::scan rest in
74 | scan l
75 |
--------------------------------------------------------------------------------
/src/lib/typing.mli:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | (** Typing *)
14 |
15 | exception Typing_error of string * string * string (** what, where, msg *)
16 |
17 | type env = (string * Types.typ_scheme) list
18 | (** Typing environment *)
19 |
20 | val type_check_fsm: ?mono:bool -> Fsm.t -> Fsm.t
21 | (** [type_check_fsm f] type checks FSM [f], raising [!Typing_error] when
22 | appropriate. Setting the optional [mono] argument also checks that all types occuring in the
23 | FSM definitions are monomorphic. This is required, for instance to generate C or VHDL code. *)
24 |
25 | val type_check_fsm_guard: ?mono:bool -> ?with_clk:bool -> Fsm.t -> Guard.t -> Guard.t
26 | (** [type_check_fsm_guard f e] type checks guard expression [e] in the context of FSM [f].
27 | As for [type_check_fsm], setting the [mono] optional argument also checks that all involved
28 | types are monomorphic.
29 | Setting the [with_clk] optional argument adds a variable named [clk] (with type [int]) to
30 | the typing environment. *)
31 |
32 | val type_check_fsm_action: ?mono:bool -> Fsm.t -> Action.t -> Action.t
33 | (** [type_check_fsm_action f a] type checks action [a] in the context of FSM [f].
34 | As for [type_check_fsm], passing the [mono] optional argument also checks that all involved
35 | types are monomorphic. *)
36 |
37 | val type_check_stimuli: Fsm.t -> Tevents.t list -> Tevents.t list
38 | (** [type_check_stimuli f s] type checks a sequence [s] of stimuli for a FSM [f], raising [!Typing_error] when
39 | appropriate (for example if an event [e] refers to a non-existent input of [f] or if the type of value asssociated
40 | to [e] does not match the type of the corresponding input in [f]. *)
41 |
--------------------------------------------------------------------------------
/docs/fsml/Fsml__Clock/index.html:
--------------------------------------------------------------------------------
1 |
2 | Fsml__Clock (fsml.Fsml__Clock)
Module Fsml__Clock
Clock
type clk = int
Clock cycle counter
val pp_clk : Ppx_deriving_runtime.Format.formatter ->clk-> Ppx_deriving_runtime.unit
val pp_clocked : (Ppx_deriving_runtime.Format.formatter ->'a-> Ppx_deriving_runtime.unit)-> Ppx_deriving_runtime.Format.formatter ->'aclocked-> Ppx_deriving_runtime.unit
val show_clocked : (Ppx_deriving_runtime.Format.formatter ->'a-> Ppx_deriving_runtime.unit)->'aclocked-> Ppx_deriving_runtime.string
--------------------------------------------------------------------------------
/src/lib/expr.mli:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | (** {1 Simple (int) expressions for FSMs} *)
14 |
15 | type ident = string
16 | [@@deriving show {with_path=false}, yojson]
17 | (** The type of identifiers occuring in expressions *)
18 |
19 | type t = {
20 | e_desc: e_desc;
21 | mutable e_typ: Types.t;
22 | }
23 | [@@deriving show {with_path=false}, yojson]
24 |
25 | and e_desc =
26 | EInt of int
27 | | EBool of bool
28 | | EVar of ident
29 | | EBinop of string * t * t
30 | [@@deriving show {with_path=false}, yojson]
31 |
32 | type value = {
33 | mutable v_desc: e_val;
34 | mutable v_typ: Types.t;
35 | }
36 | [@@deriving show {with_path=false}]
37 |
38 | and e_val =
39 | | Int of int
40 | | Bool of bool
41 | | Prim of (e_val list -> e_val)
42 | | Unknown
43 | | Enum of string (** This is a hack to allow tracing of state transitions *)
44 | [@@deriving show {with_path=false}]
45 |
46 | val of_value: e_val -> t
47 |
48 | val is_const: t -> bool
49 |
50 | val is_var_test: string -> t -> bool
51 |
52 | (** {2 Builders} *)
53 |
54 | val mk_bool_expr: e_desc -> t
55 | val mk_int_expr: e_desc -> t
56 |
57 | (** {2 Evaluation} *)
58 |
59 | type env = (ident * e_val) list
60 | [@@deriving show]
61 | (** Evaluation environment *)
62 |
63 | (** {2 Printing} *)
64 |
65 | val to_string: t -> string
66 |
67 | val string_of_value: e_val -> string
68 |
69 | (** {2 Simulation} *)
70 |
71 | val lookup_env: env -> ident -> e_val
72 | val update_env: env -> ident * e_val -> env
73 |
74 | exception Unbound_id of ident
75 | exception Unknown_id of ident
76 | exception Illegal_expr of t
77 | exception Illegal_value of e_val
78 |
79 | val eval: env -> t -> e_val
80 |
81 | val bool_val: e_val -> bool
82 | val int_val: e_val -> int
83 |
--------------------------------------------------------------------------------
/examples/ex3/vhdl/tb.vhd:
--------------------------------------------------------------------------------
1 | library ieee;
2 | use ieee.std_logic_1164.all;
3 | use ieee.numeric_std.all;
4 |
5 | -- Note : this file was, mostly, automatically generated using
6 | -- the RFSM compiler (https://github.com/jserot/rfsm)
7 |
8 | entity tb is
9 | end entity;
10 |
11 | architecture struct of tb is
12 |
13 | component pgcd is
14 | port(
15 | start: in std_logic;
16 | m: in integer range 0 to 255;
17 | n: in integer range 0 to 255;
18 | rdy: out std_logic;
19 | r: out integer range 0 to 255;
20 | clk: in std_logic;
21 | rst: in std_logic
22 | );
23 | end component;
24 |
25 | signal clk: std_logic;
26 | signal rst: std_logic;
27 | signal start: std_logic;
28 | signal m: integer range 0 to 255;
29 | signal n: integer range 0 to 255;
30 | signal rdy: std_logic;
31 | signal r: integer range 0 to 255;
32 |
33 | begin
34 |
35 | inp_data: process
36 | type t_vc is record date: time; val1: integer; val2: integer; end record;
37 | type t_vcs is array ( 0 to 0 ) of t_vc;
38 | constant vcs : t_vcs := ( others => (0 ns, 24, 36) );
39 | variable i : natural := 0;
40 | variable t : time := 0 ns;
41 | begin
42 | for i in 0 to 0 loop
43 | wait for vcs(i).date-t;
44 | m <= vcs(i).val1;
45 | n <= vcs(i).val2;
46 | t := vcs(i).date;
47 | end loop;
48 | wait;
49 | end process;
50 |
51 | inp_start: process
52 | type t_vc is record date: time; val: std_logic; end record;
53 | type t_vcs is array ( 0 to 2 ) of t_vc;
54 | constant vcs : t_vcs := ( (0 ns, '0'), (15 ns, '1'), (35 ns, '0') );
55 | variable i : natural := 0;
56 | variable t : time := 0 ns;
57 | begin
58 | for i in 0 to 2 loop
59 | wait for vcs(i).date-t;
60 | Start <= vcs(i).val;
61 | t := vcs(i).date;
62 | end loop;
63 | wait;
64 | end process;
65 |
66 | inp_clk: process
67 | type t_periodic is record period: time; t1: time; t2: time; end record;
68 | constant periodic : t_periodic := ( 10 ns, 10 ns, 100 ns );
69 | variable t : time := 0 ns;
70 | begin
71 | clk <= '0';
72 | wait for periodic.t1;
73 | t := t + periodic.t1;
74 | while ( t < periodic.t2 ) loop
75 | clk <= '1';
76 | wait for periodic.period/2;
77 | clk <= '0';
78 | wait for periodic.period/2;
79 | t := t + periodic.period;
80 | end loop;
81 | wait;
82 | end process;
83 |
84 | inp_reset: process
85 | begin
86 | rst <= '1';
87 | wait for 1 ns;
88 | rst <= '0';
89 | wait for 100 ns;
90 | wait;
91 | end process;
92 |
93 | UUT: pgcd port map(start, m, n, rdy, r, clk, rst);
94 |
95 | end architecture;
96 |
--------------------------------------------------------------------------------
/src/lib/vhdl.mli:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | (** {1 VHDL backend} *)
14 |
15 | type config = {
16 | mutable state_var: string; (** Name of signal storing the current state (default: [state]) *)
17 | mutable reset_sig: string; (** Name of the asynchronous reset input (default: [rst]) *)
18 | mutable clk_sig: string; (** Name of the clock input (default: [clk]) *)
19 | mutable use_numeric_std: bool; (** Encode integers as VHDL [Signed] or [Unsigned] (default: false) *)
20 | mutable act_sem: act_semantics; (** Use sequential or synchronous semantics for actions (default: sequential) *)
21 | }
22 |
23 | and act_semantics =
24 | | Sequential
25 | | Synchronous
26 | (** Interpretation of actions associated to transitions.
27 | With a a [Sequential] interpretation, the sequence [x:=x+1,y:=x], with [x=1], will lead to [x=2,y=2].
28 | With a a [Synchronous] interpretation, the same sequence will lead to [x=2,y=1].
29 | The default behavior is set to [Sequential] in order to make OCaml, C and VHDL behaviors observationaly equivalent.
30 | Synchronous behavior is implemented (and can be selected) but potentially breaks this equivalence because it
31 | is not (yet) implemented at the OCaml and C level. *)
32 |
33 | val cfg : config
34 |
35 | exception Error of string * string (* where, message *)
36 |
37 | val write: ?dir:string -> prefix:string -> Fsm.t -> unit
38 | (** [write prefix m] writes in file [prefix.vhd] a representation of FSM [m] as a VHDL entity and architecture.
39 | The architecture is a synchronous FSM, with a [clk] signal and a asynchronous, active high, [rst] signal.
40 | Transitions are performed on the rising edge of the [clk] signal.
41 | The generated file is written in the current working directory unless a target directory is specified
42 | with the [dir] argument. If the target directory does not exist, an attempt is made to create it. *)
43 |
--------------------------------------------------------------------------------
/docs/fsml/Fsml/Clock/index.html:
--------------------------------------------------------------------------------
1 |
2 | Clock (fsml.Fsml.Clock)
Module Fsml.Clock
Clock
type clk = int
Clock cycle counter
val pp_clk : Ppx_deriving_runtime.Format.formatter ->clk-> Ppx_deriving_runtime.unit
val pp_clocked : (Ppx_deriving_runtime.Format.formatter ->'a-> Ppx_deriving_runtime.unit)-> Ppx_deriving_runtime.Format.formatter ->'aclocked-> Ppx_deriving_runtime.unit
val show_clocked : (Ppx_deriving_runtime.Format.formatter ->'a-> Ppx_deriving_runtime.unit)->'aclocked-> Ppx_deriving_runtime.string
--------------------------------------------------------------------------------
/src/lib/types.mli:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | (** Types *)
14 |
15 | type t =
16 | | TyInt of sign attr * size attr * range attr
17 | | TyBool
18 | | TyArrow of t * t (** Internal use only *)
19 | | TyProduct of t list (** Internal use only *)
20 | | TyVar of t var (** Internal use only *)
21 | [@@deriving show {with_path=false}, yojson]
22 |
23 | and 'a attr =
24 | | Const of 'a
25 | | Var of ('a attr) var
26 | [@@deriving show {with_path=false}, yojson]
27 |
28 | and 'a var =
29 | { stamp: string;
30 | mutable value: 'a value }
31 | [@@deriving show {with_path=false}, yojson]
32 |
33 | and 'a value =
34 | | Unknown
35 | | Known of 'a
36 | [@@deriving show {with_path=false}, yojson]
37 |
38 | and sign = Signed | Unsigned [@@deriving show {with_path=false}, yojson]
39 | and size = int [@@deriving show {with_path=false}, yojson]
40 | and range = { lo: int; hi: int } [@@deriving show {with_path=false}, yojson]
41 |
42 | type typ_scheme =
43 | { ts_params: ts_params;
44 | ts_body: t }
45 | [@@deriving show {with_path=false}, yojson]
46 |
47 | and ts_params = {
48 | tp_typ: (t var) list;
49 | tp_sign: ((sign attr) var) list;
50 | tp_size: ((size attr) var) list;
51 | tp_range: ((range attr) var) list;
52 | }
53 |
54 | (** {2 Builders} *)
55 |
56 | val new_type_var: unit -> t var
57 | (** [new_type_var ()] returns a fresh type variable *)
58 |
59 | val new_attr_var: unit -> ('a attr) var
60 | (** [new_attr_var ()] returns a fresh type attribute variable *)
61 |
62 | val type_int: unit -> t
63 |
64 | val trivial_scheme: t -> typ_scheme
65 |
66 | (** {2 Unification} *)
67 |
68 | exception TypeConflict of t * t
69 | exception TypeCircularity of t * t
70 |
71 | val unify: t -> t -> unit
72 |
73 | val type_instance: typ_scheme -> t
74 |
75 | val real_type: t -> t
76 | val real_attr: 'a attr -> 'a attr
77 |
78 | exception Polymorphic of t
79 |
80 | val mono_type: t -> t
81 | (** Remove all type variables from type representation [t]. Raises [!Polymorphic] if
82 | [t] contains unresolved type variables. *)
83 |
84 | (** {2 Printing} *)
85 |
86 | val to_string: t -> string
87 |
--------------------------------------------------------------------------------
/src/lib/simul.mli:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | (** {1 Simulation} *)
14 |
15 | type ctx = {
16 | state: State.t;
17 | env: Expr.env
18 | }
19 | [@@deriving show]
20 | (** A context is the dynamic view of a FSM. It records its current state
21 | and, in [env], the value of its inputs, outputs and local variables. *)
22 |
23 | (** {2 Simulation functions} *)
24 |
25 | val step: ctx -> Fsm.t -> Event.t list * ctx
26 | (** [step ctx m] performs a single simulation step, within context [ctx] of FSM [m].
27 | The first fireable transition is selected according to the current state and
28 | value of the inputs and local variables. The actions associated to this transition
29 | are executed and both the state and context are updated accordingly.
30 | If no fireable transition is found, the context is left unchanged.
31 | Returns a list timed output events and the updated context. *)
32 |
33 | val run:
34 | ?ctx:ctx ->
35 | ?stop_when:Guard.t list ->
36 | ?stop_after:Clock.clk ->
37 | ?trace:bool ->
38 | stim:Tevents.t list ->
39 | Fsm.t ->
40 | Tevents.t list * (ctx Clock.clocked) list
41 | (** [run ctx stim m] performs a multi-step simulation of FSM [m] starting from
42 | context [ctx] and applying a ordered sequence of stimuli listed in [stim], producing
43 | a sequence of timed event sets and, if the optional argument [trace] is set, the corresponding sequence of contexts.
44 | FSM [m] is first type-checked.
45 | If the initial context [ctx] is not given it is built by triggering the initial transition
46 | of [m] and gathers its inputs, local variables and outputs.
47 | Passing an initial context may be used to start a simulation from a given state obtained from
48 | a previous simulation.
49 | If a list of guards is given as optional argument [stop_when], then simulation stops as soon all of these guards
50 | of the these guards becomes true. The guards may include relational operators on the special variable
51 | [clk], refering to the current simulation step. Ex: [-stop_when [%fsm_guard {|rdy=1|}]];
52 | If a clock cycle count [n] is given as optional argument [stop_after], then simulation stops after exactly
53 | [n] steps (so that [-stop_after n] is actually a shorthand for [-stop_when "clk=n"]). *)
54 |
--------------------------------------------------------------------------------
/docs/fsml/Fsml__Seqmodel/index.html:
--------------------------------------------------------------------------------
1 |
2 | Fsml__Seqmodel (fsml.Fsml__Seqmodel)
val write : ?dir:string->prefix:string->Fsml.Fsm.t-> unit
write prefix m writes in files prefix.h and prefix.c a representation of FSM m as a C function. This function has prototype void fsm_xxx(ctx_t *ctx), where xxx is m.m_id and ctx_t is the type of a structure recording the value of inputs and outputs of the machine. Each call to the fsm_xxx function will correspond to one execution step of the machine: it first looks for a fireable transition (depending on the values of the inputs read in the context ctx and of the local variables) and, if found, performs the action associated to this transition (updating the value of outputs and local variables) and updates the current state. The generated files are written in the current working directory unless a target directory is specified with the dir argument. If the target directory does not exist, an attempt is made to create it.
--------------------------------------------------------------------------------
/src/lib/builtins.ml:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | open Types
14 |
15 | let type_arithm () =
16 | let sg = Types.new_attr_var () in
17 | let sz = Types.new_attr_var () in
18 | let rg = Types.new_attr_var () in
19 | { ts_params={tp_typ=[]; tp_sign=[sg]; tp_size=[]; tp_range=[rg]};
20 | ts_body=TyArrow
21 | (TyProduct
22 | [TyInt (Var sg, Var sz, Var rg); TyInt (Var sg, Var sz, Var rg)],
23 | TyInt (Var sg, Var sz, Var rg)) }
24 |
25 | let type_compar () =
26 | let t = Types.new_type_var () in
27 | { ts_params={tp_typ=[t]; tp_sign=[]; tp_size=[]; tp_range=[]};
28 | ts_body=TyArrow (TyProduct [TyVar t; TyVar t], TyBool) }
29 |
30 | exception Unknown_value
31 |
32 | let encode_int n =
33 | Expr.Int n
34 | let decode_int = function
35 | | Expr.Int n -> n
36 | | Expr.Unknown -> raise Unknown_value
37 | | _ -> failwith "Builtins.decode_int" (* should not happen *)
38 | let encode_bool b =
39 | Expr.Bool b
40 | (* let decode_bool = function
41 | * | Expr.Bool b -> b
42 | * | Expr.Unknown -> raise Unknown_value
43 | * | _ -> failwith "Builtins.decode bool" (\* should not happen *\) *)
44 |
45 | let prim2 encode op decode =
46 | function
47 | | [v1;v2] ->
48 | begin
49 | try encode (op (decode v1) (decode v2))
50 | with Unknown_value -> Expr.Unknown
51 | end
52 | | _ -> failwith "Builtins.prim2"
53 |
54 | let cprim2 op =
55 | let decode v = v in
56 | function
57 | | [v1;v2] ->
58 | begin
59 | try encode_bool (op (decode v1) (decode v2))
60 | with Unknown_value -> Expr.Unknown
61 | end
62 | | _ -> failwith "Builtins.cprim2"
63 |
64 | let prims = [
65 | "+", (type_arithm (), prim2 encode_int ( + ) decode_int);
66 | "-", (type_arithm (), prim2 encode_int ( - ) decode_int);
67 | "*", (type_arithm (), prim2 encode_int ( * ) decode_int);
68 | "/", (type_arithm (), prim2 encode_int ( / ) decode_int);
69 | "=", (type_compar () , cprim2 ( = ));
70 | "!=", (type_compar (), cprim2 ( <> ));
71 | "<", (type_compar (), cprim2 ( < ));
72 | ">", (type_compar (), cprim2 ( > ));
73 | "<=", (type_compar (), cprim2 ( <= ));
74 | ">=", (type_compar (), cprim2 ( >= ))
75 | ]
76 |
77 | let typing_env = List.map (fun (id, (ty, _)) -> id, ty) prims
78 |
79 | let eval_env = List.map (fun (id, (_, f)) -> id, Expr.Prim f) prims
80 |
--------------------------------------------------------------------------------
/docs/fsml/Fsml/Seqmodel/index.html:
--------------------------------------------------------------------------------
1 |
2 | Seqmodel (fsml.Fsml.Seqmodel)
val write : ?dir:string->prefix:string->Fsm.t-> unit
write prefix m writes in files prefix.h and prefix.c a representation of FSM m as a C function. This function has prototype void fsm_xxx(ctx_t *ctx), where xxx is m.m_id and ctx_t is the type of a structure recording the value of inputs and outputs of the machine. Each call to the fsm_xxx function will correspond to one execution step of the machine: it first looks for a fireable transition (depending on the values of the inputs read in the context ctx and of the local variables) and, if found, performs the action associated to this transition (updating the value of outputs and local variables) and updates the current state. The generated files are written in the current working directory unless a target directory is specified with the dir argument. If the target directory does not exist, an attempt is made to create it.
write fname m writes a .dot representation of FSM m in file fname. Rendering can be modified with the options optional argument.
val view : ?options:options->?fname:string->?cmd:string->Fsml.Fsm.t-> int
view m views FSM m by first writing its .dot representation in file and then launching a DOT viewer application. The name of the output file and of the viewer application can be changed using the fname and cmd optional arguments. Returns the issued command exit status.
eval env e evaluates guard expression e in environment env, returning the corresponding boolean value. Raises Illegal_guard_expr if the expression does not denote a boolean value.
eval env e evaluates guard expression e in environment env, returning the corresponding boolean value. Raises Illegal_guard_expr if the expression does not denote a boolean value.
val write : string ->?options:options->Fsm.t-> unit
write fname m writes a .dot representation of FSM m in file fname. Rendering can be modified with the options optional argument.
val view : ?options:options->?fname:string->?cmd:string->Fsm.t-> int
view m views FSM m by first writing its .dot representation in file and then launching a DOT viewer application. The name of the output file and of the viewer application can be changed using the fname and cmd optional arguments. Returns the issued command exit status.
(src,guards,actions,dst) means that the FSM will go from state src to state dst whenever all guards listed in guards evaluate to true, performing, sequentially, all actions listed in actions.
val pp : Ppx_deriving_runtime.Format.formatter ->t-> Ppx_deriving_runtime.unit
is_fireable src env t returns true iff transition t is fireable when the enclosing FSM is in state state and the inputs and local variables have values recorded in environment env.
(src,guards,actions,dst) means that the FSM will go from state src to state dst whenever all guards listed in guards evaluate to true, performing, sequentially, all actions listed in actions.
val pp : Ppx_deriving_runtime.Format.formatter ->t-> Ppx_deriving_runtime.unit
is_fireable src env t returns true iff transition t is fireable when the enclosing FSM is in state state and the inputs and local variables have values recorded in environment env.
A timed event set (TES) is a list of events occuring at a given clock cycle. Example 4, [x:=1,y:=1] means that both x and y take value 1 at clock cycle 4. TES are used by simulator both to represent input stimuli and output events
val pp : Ppx_deriving_runtime.Format.formatter ->t-> Ppx_deriving_runtime.unit
changes name vcs builds a list of TES from a list vcs of value changes related to signal name, a value change being a pair of the clk cycle and a value. Ex: changes "x" [0,Int 1; 2,Int 0] is [0,[x:=1]; 2,[x:=0]].
A timed event set (TES) is a list of events occuring at a given clock cycle. Example 4, [x:=1,y:=1] means that both x and y take value 1 at clock cycle 4. TES are used by simulator both to represent input stimuli and output events
val pp : Ppx_deriving_runtime.Format.formatter ->t-> Ppx_deriving_runtime.unit
changes name vcs builds a list of TES from a list vcs of value changes related to signal name, a value change being a pair of the clk cycle and a value. Ex: changes "x" [0,Int 1; 2,Int 0] is [0,[x:=1]; 2,[x:=0]].
--------------------------------------------------------------------------------
/src/lib/simul.ml:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | open Fsm
14 |
15 | type ctx = {
16 | state: State.t;
17 | env: Expr.env
18 | }
19 | [@@deriving show]
20 |
21 | let check_fsm m = Typing.type_check_fsm m
22 | let check_stimuli m st = Typing.type_check_stimuli m st
23 |
24 | let output_state_events m state =
25 | assert (List.mem_assoc state m.states);
26 | List.assoc state m.states |> List.map (fun (o,e) -> Action.Assign (o,e))
27 |
28 | let step ctx m =
29 | match List.find_opt (Transition.is_fireable ctx.state (Builtins.eval_env @ ctx.env)) m.trans with
30 | | Some (src, _, acts, dst) ->
31 | let acts' = acts @ output_state_events m dst in
32 | let evs = List.concat @@ List.map (Action.perform (Builtins.eval_env @ ctx.env)) acts' in
33 | (if src <> dst then ("state",Expr.Enum dst)::evs else evs),
34 | { state = dst;
35 | env = List.fold_left Expr.update_env ctx.env evs }
36 | | None ->
37 | [],
38 | ctx
39 |
40 | let run ?ctx ?(stop_when=[]) ?(stop_after=0) ?(trace=false) ~stim m =
41 | let open Clock in
42 | let m = check_fsm m in
43 | let stim = check_stimuli m stim in
44 | let stop_conds =
45 | let open Expr in
46 | if stop_after > 0 then
47 | [mk_bool_expr (EBinop(">=", (mk_int_expr (EVar "clk")), (mk_int_expr (EInt stop_after))))]
48 | else
49 | List.map (Typing.type_check_fsm_guard ~with_clk:true m) stop_when in
50 | let eval_stop_conds clk ctx =
51 | let env' = Builtins.eval_env @ ctx.env @ ["clk", Expr.Int clk] in
52 | List.for_all (Guard.eval env') stop_conds in
53 | let trace_log = ref ([] : ctx clocked list) in
54 | let rec eval (clk, ctx, evs) stim =
55 | if eval_stop_conds clk ctx then List.rev evs, List.rev !trace_log (* Done ! *)
56 | else
57 | match stim with
58 | | (t,evs')::rest when t=clk ->
59 | let ctx' = { ctx with env = List.fold_left Expr.update_env ctx.env evs' } in
60 | let evs'', ctx'' = step ctx' m in
61 | if trace then trace_log := (t,ctx'')::!trace_log;
62 | let evs''' =
63 | begin match evs with
64 | | (t',es)::rest when t'=t -> (t',es@evs'')::rest
65 | | _ -> (t,evs'')::evs
66 | end in
67 | eval (clk+1, ctx'', evs''') rest
68 | | _ -> (* No applicable stimuli *)
69 | let evs', ctx' = step ctx m in
70 | if trace then trace_log := (clk,ctx')::!trace_log;
71 | eval (clk+1, ctx', (clk, evs')::evs) [] in
72 | let ctx, evs = match ctx, m.Fsm.itrans with
73 | | Some c, _ ->
74 | c,
75 | []
76 | | None, (s0,acts0) ->
77 | let env0 = List.map (fun (id,_) -> id, Expr.Unknown) (m.inps @ m.outps @ m.vars) in
78 | let acts0' = acts0 @ output_state_events m s0 in
79 | let evs0 = List.concat @@ List.map (Action.perform (Builtins.eval_env @ env0)) acts0' in
80 | { state = s0; env = List.fold_left Expr.update_env env0 evs0 },
81 | [0, ("state",Expr.Enum s0)::evs0] in
82 | if trace then trace_log := [0,ctx];
83 | eval (0, ctx, evs) stim
84 |
--------------------------------------------------------------------------------
/src/lib/expr.ml:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | (** Fsm expressions *)
14 |
15 | type ident = string
16 | [@@deriving show {with_path=false}, yojson]
17 |
18 | type t = {
19 | e_desc: e_desc;
20 | mutable e_typ: Types.t;
21 | }
22 | [@@deriving show {with_path=false}, yojson]
23 |
24 | and e_desc =
25 | EInt of int
26 | | EBool of bool
27 | | EVar of ident
28 | | EBinop of string * t * t
29 | [@@deriving show {with_path=false}, yojson]
30 |
31 | type value = {
32 | mutable v_desc: e_val;
33 | mutable v_typ: Types.t;
34 | }
35 | [@@deriving show {with_path=false}]
36 |
37 | and e_val =
38 | | Int of int
39 | | Bool of bool
40 | | Prim of (e_val list -> e_val)
41 | | Unknown
42 | | Enum of string
43 | [@@deriving show {with_path=false}]
44 |
45 | let of_value v = match v with
46 | | Int v -> { e_desc=EInt v; e_typ=Types.type_int () }
47 | | Bool v -> { e_desc=EBool v; e_typ=Types.TyBool }
48 | | _ -> failwith "Expr.of_value"
49 |
50 | let is_const e =
51 | match e.e_desc with
52 | | EInt _ -> true
53 | | EBool _ -> true
54 | | _ -> false
55 |
56 | let is_var_test v e =
57 | match e.e_desc with
58 | | EBinop (op, {e_desc=EVar v'; _}, _)
59 | | EBinop (op, _, {e_desc=EVar v'; _}) ->
60 | v'=v && List.mem op ["="; "<"; ">"; "<="; ">=" ]
61 | | _ -> false
62 |
63 | let mk_bool_expr e = { e_desc = e; e_typ = Types.TyBool }
64 | let mk_int_expr e = { e_desc = e; e_typ = Types.type_int () }
65 |
66 | type env = (ident * e_val) list
67 | [@@deriving show]
68 |
69 | exception Unbound_id of ident
70 | exception Unknown_id of ident
71 | exception Illegal_expr of t
72 | exception Illegal_value of e_val
73 |
74 | let lookup_env env id =
75 | try
76 | match List.assoc id env with
77 | | Unknown -> raise (Unbound_id id)
78 | | v -> v
79 | with
80 | Not_found -> raise (Unknown_id id)
81 |
82 | let update_env env (k,v) =
83 | let rec scan = function
84 | | [] -> []
85 | | (k',v')::rest -> if k=k' then (k, v)::rest else (k',v')::scan rest in
86 | scan env
87 |
88 | let rec eval : env -> t -> e_val = fun env exp ->
89 | match exp.e_desc with
90 | | EInt v -> Int v
91 | | EBool v -> Bool v
92 | | EVar id -> lookup_env env id
93 | | EBinop (op, e1, e2) ->
94 | begin match lookup_env env op, eval env e1, eval env e2 with
95 | | Prim f, v1, v2 -> f [v1;v2]
96 | | _, _, _ -> raise (Illegal_expr exp)
97 | end
98 |
99 | let rec to_string e = match e.e_desc with
100 | EInt c -> string_of_int c
101 | | EBool c -> if c then "'1'" else "'0'"
102 | | EVar n -> n
103 | | EBinop (op,e1,e2) -> to_string e1 ^ op ^ to_string e2 (* TODO : add parens *)
104 |
105 | let string_of_value v = match v with
106 | | Int c -> string_of_int c
107 | | Bool b -> if b then "'1'" else "'0'"
108 | | Prim _ -> ""
109 | | Unknown -> ""
110 | | Enum s -> s
111 |
112 | let bool_val v = match v with Bool v -> v | _ -> raise (Illegal_value v)
113 | let int_val v = match v with Int v -> v | _ -> raise (Illegal_value v)
114 |
115 |
116 |
--------------------------------------------------------------------------------
/src/lib/fsm.mli:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | (** {1 Finite State Machines} *)
14 |
15 | type t = {
16 | id: string; (** Name *)
17 | states: (State.t * Valuation.t) list;
18 | inps: (string * Types.t) list; (** Inputs *)
19 | outps: (string * Types.t) list; (** Outputs *)
20 | vars: (string * Types.t) list; (** Local variables *)
21 | trans: Transition.t list;
22 | itrans: State.t * Action.t list; (** Initial transition *)
23 | } [@@deriving show {with_path=false}, yojson]
24 | (** The static description of a FSM *)
25 |
26 | (** {2 Transformation functions} *)
27 |
28 | exception Unknown_output of string
29 |
30 | val mealy_outps : ?outps:string list -> t -> t
31 | (** [mealy_outps os m] returns the FSM obtained by moving the assignation of outputs
32 | listed in [outps] from states to all incoming transitions. When the [outps] parameter is empty
33 | or omitted, the transformation is applied to all outputs occuring in each state. Raises [Unknown_output] if
34 | [outps] contains a symbol not declared as output. *)
35 |
36 | val moore_outps : ?outps:string list -> t -> t
37 | (** [moore_outps os m] is the dual function of {!mealy_outps}. For each output [o] listed in
38 | in [outps], whenever all transitions leading to a state [s] carry the same action [o:=v], it removes
39 | these actions and adds the assignation [o=v] to state [s]. The transformation is not applied if
40 | - the corresponding action does not occur on all transitions leading to state [s],
41 | - the value assigned to output [o] is not a constant,
42 | - not all actions assign the same value to [o]
43 | If [outps] is omitted ot empty, the transformation is applied to all outputs. Raises [Unknown_output] if
44 | [outps] contains a symbol not declared as output. *)
45 |
46 | exception Unknown_var of string
47 | exception Illegal_var_type of string * Types.t
48 |
49 | val defactorize: vars:(string * Expr.e_val) list -> ?cleaned:bool -> t -> t
50 | (** [defactorize vars m] returns an equivalent FSM obtained by removing variable listed in [vars] from [m] and
51 | introducing new states accordingly.
52 | The value attached to each variable is used to select the initial state in the defactorized FSM.
53 | Unreachable states are removed from the
54 | resulting automata unlesse the optional argument [clean] is set to false. Raises {!Unknown_var} if
55 | [vars] contains a symbol not declared as variable. Raises {!Illegal_var_type} if
56 | the specified var(s) do(es) not have an enumerable type (i.e. have not been declared with a range). *)
57 |
58 | val clean: t -> t
59 | (** [clean m] removes all unreachable states (and associated transitions) from m *)
60 |
61 | (** {2 JSON export/import} *)
62 |
63 | val to_string: t -> string
64 | (** [to_string m] writes a representation of FSM [m] as a string using the [Yojson] library. *)
65 |
66 | val from_string: string -> t
67 | (** [from_string s] returns the FSM [m] stored in string [s] using the [Yojson] library *)
68 |
69 | val to_file: fname:string -> t -> unit
70 | (** [to_file f] writes a representation of FSM [m] in file [f] using the [Yojson] library. *)
71 |
72 | val from_file: fname:string -> t
73 | (** [from_file f] returns the FSM [m] stored in file [f] using the [Yojson] library *)
74 |
--------------------------------------------------------------------------------
/docs/fsml/Fsml/Typing/index.html:
--------------------------------------------------------------------------------
1 |
2 | Typing (fsml.Fsml.Typing)
type_check_fsm f type checks FSM f, raising !Typing_error when appropriate. Setting the optional mono argument also checks that all types occuring in the FSM definitions are monomorphic. This is required, for instance to generate C or VHDL code.
val type_check_fsm_guard : ?mono:bool->?with_clk:bool->Fsm.t->Guard.t->Guard.t
type_check_fsm_guard f e type checks guard expression e in the context of FSM f. As for type_check_fsm, setting the mono optional argument also checks that all involved types are monomorphic. Setting the with_clk optional argument adds a variable named clk (with type int) to the typing environment.
type_check_fsm_action f a type checks action a in the context of FSM f. As for type_check_fsm, passing the mono optional argument also checks that all involved types are monomorphic.
type_check_stimuli f s type checks a sequence s of stimuli for a FSM f, raising !Typing_error when appropriate (for example if an event e refers to a non-existent input of f or if the type of value asssociated to e does not match the type of the corresponding input in f.
--------------------------------------------------------------------------------
/src/lib/dot.ml:
--------------------------------------------------------------------------------
1 | (**********************************************************************)
2 | (* *)
3 | (* This file is part of the FSML library *)
4 | (* github.com/jserot/fsml *)
5 | (* *)
6 | (* Copyright (c) 2020-present, Jocelyn SEROT. All rights reserved. *)
7 | (* *)
8 | (* This source code is licensed under the license found in the *)
9 | (* LICENSE file in the root directory of this source tree. *)
10 | (* *)
11 | (**********************************************************************)
12 |
13 | type options = {
14 | mutable node_shape: string;
15 | mutable node_style: string;
16 | mutable rankdir: string;
17 | mutable layout: string;
18 | mutable mindist: float
19 | }
20 |
21 | let default_options = {
22 | node_shape = "circle";
23 | node_style = "solid";
24 | rankdir = "UD";
25 | layout = "dot";
26 | mindist = 1.0;
27 | }
28 |
29 | let output oc ?(options=default_options) m =
30 | let open Fsm in
31 | let ini_id = "_ini" in
32 | let dump_istate () =
33 | Printf.fprintf oc "%s [shape=point; label=\"\"; style = invis]\n" ini_id in
34 | let string_of_output_valuation vs =
35 | Misc.string_of_list ~f:(function (n,v) -> "\\n" ^ n ^ "=" ^ Expr.to_string v) ~sep:"" vs in
36 | let dump_state (id,oval) =
37 | Printf.fprintf oc "%s [label = \"%s%s\", shape = %s, style = %s]\n"
38 | id
39 | id
40 | (string_of_output_valuation oval)
41 | options.node_shape
42 | options.node_style in
43 | let string_of_guards guards =
44 | let ss = List.map Guard.to_string guards in
45 | let l = List.fold_left (fun m s -> max m (String.length s)) 0 ss in
46 | let s = Misc.string_of_list ~f:Fun.id ~sep:"\\n" ss in
47 | s, l in
48 | let string_of_actions actions =
49 | let ss = List.map Action.to_string actions in
50 | let l = List.fold_left (fun m s -> max m (String.length s)) 0 ss in
51 | let s = Misc.string_of_list ~f:Fun.id ~sep:"\\n" ss in
52 | s, l in
53 | let dump_itransition (dst,actions) =
54 | let s, l = string_of_actions actions in
55 | match s with
56 | | "" ->
57 | Printf.fprintf oc "%s->%s\n" ini_id dst
58 | | _ ->
59 | let sep = "\n" ^ String.make l '_' ^ "\n" in
60 | Printf.fprintf oc "%s->%s [label=\"%s%s\"]\n" ini_id dst sep s in
61 | let dump_transition (src,guards,actions,dst) =
62 | let s1, l1 = string_of_guards guards in
63 | let s2, l2 = string_of_actions actions in
64 | match s1, s2 with
65 | | "", "" ->
66 | Printf.fprintf oc "%s->%s\n" src dst
67 | | _, "" ->
68 | Printf.fprintf oc "%s->%s [label=\"%s\"]\n" src dst s1
69 | | "", _ ->
70 | let sep = "\n" ^ String.make l2 '_' ^ "\n" in
71 | Printf.fprintf oc "%s->%s [label=\"%s%s\"]\n" src dst sep s2
72 | | _, _ ->
73 | let sep = "\n" ^ String.make (max l1 l2) '_' ^ "\n" in
74 | Printf.fprintf oc "%s->%s [label=\"%s%s%s\"]\n" src dst s1 sep s2 in
75 | Printf.fprintf oc "digraph %s {\nlayout = %s;\nrankdir = %s;\nsize = \"8.5,11\";\nlabel = \"\"\n center = 1;\n nodesep = \"0.350000\"\n ranksep = \"0.400000\"\n fontsize = 14;\nmindist=\"%1.1f\"\n"
76 | m.id
77 | options.layout
78 | options.rankdir
79 | options.mindist;
80 | dump_istate ();
81 | List.iter dump_state m.states;
82 | dump_itransition m.itrans;
83 | List.iter dump_transition m.trans;
84 | Printf.fprintf oc "}\n"
85 |
86 | let write fname ?(options=default_options) m =
87 | let oc = open_out fname in
88 | output oc ~options m;
89 | Printf.printf "Wrote file %s\n" fname;
90 | close_out oc
91 |
92 | let view ?(options=default_options) ?(fname="") ?(cmd="open -a Graphviz") m =
93 | let fname = match fname with
94 | | "" -> "/tmp/" ^ m.Fsm.id ^ "_fsm.dot"
95 | | _ -> fname in
96 | let _ = write fname ~options m in
97 | Sys.command (cmd ^ " " ^ fname)
98 |
--------------------------------------------------------------------------------
/docs/fsml/Fsml__Typing/index.html:
--------------------------------------------------------------------------------
1 |
2 | Fsml__Typing (fsml.Fsml__Typing)
type_check_fsm f type checks FSM f, raising !Typing_error when appropriate. Setting the optional mono argument also checks that all types occuring in the FSM definitions are monomorphic. This is required, for instance to generate C or VHDL code.
type_check_fsm_guard f e type checks guard expression e in the context of FSM f. As for type_check_fsm, setting the mono optional argument also checks that all involved types are monomorphic. Setting the with_clk optional argument adds a variable named clk (with type int) to the typing environment.
type_check_fsm_action f a type checks action a in the context of FSM f. As for type_check_fsm, passing the mono optional argument also checks that all involved types are monomorphic.
type_check_stimuli f s type checks a sequence s of stimuli for a FSM f, raising !Typing_error when appropriate (for example if an event e refers to a non-existent input of f or if the type of value asssociated to e does not match the type of the corresponding input in f.
Use sequential or synchronous semantics for actions (default: sequential)
}
and act_semantics =
| Sequential
| Synchronous
Interpretation of actions associated to transitions. With a a Sequential interpretation, the sequence x:=x+1,y:=x, with x=1, will lead to x=2,y=2. With a a Synchronous interpretation, the same sequence will lead to x=2,y=1. The default behavior is set to Sequential in order 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.
val write : ?dir:string->prefix:string->Fsml.Fsm.t-> unit
write prefix m writes in file prefix.vhd a representation of FSM m as a VHDL entity and architecture. The architecture is a synchronous FSM, with a clk signal and a asynchronous, active high, rst signal. Transitions are performed on the rising edge of the clk signal. The generated file is written in the current working directory unless a target directory is specified with the dir argument. If the target directory does not exist, an attempt is made to create it.
Use sequential or synchronous semantics for actions (default: sequential)
}
and act_semantics =
| Sequential
| Synchronous
Interpretation of actions associated to transitions. With a a Sequential interpretation, the sequence x:=x+1,y:=x, with x=1, will lead to x=2,y=2. With a a Synchronous interpretation, the same sequence will lead to x=2,y=1. The default behavior is set to Sequential in order 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.
val write : ?dir:string->prefix:string->Fsm.t-> unit
write prefix m writes in file prefix.vhd a representation of FSM m as a VHDL entity and architecture. The architecture is a synchronous FSM, with a clk signal and a asynchronous, active high, rst signal. Transitions are performed on the rising edge of the clk signal. The generated file is written in the current working directory unless a target directory is specified with the dir argument. If the target directory does not exist, an attempt is made to create it.