Query a hierarchical Hardcaml circuit by UID with full tracing

test.ml

open Core
open Hardcaml

(* Set this before construcing the circuit so that stack traces are stored inside
   signals. *)
let () = Caller_id.set_mode Full_trace

(* A simple hierarchical circuit *)
module Add_sub = struct
  module I = struct
    type 'a t =
      { a : 'a[@bits 8]
      ; b : 'a[@bits 8]
      ; sel : 'a
      }
    [@@deriving sexp_of, hardcaml]
  end
  module O = struct
    type 'a t =
      { c : 'a[@bits 8] }
    [@@deriving sexp_of, hardcaml]
  end

  open Signal

  let create _scope (i : _ I.t) =
    let add = i.a +: i.b in
    let sub = i.a -: i.b in
    { O.c = mux2 i.sel add sub }
  ;;

  let hierarchical scope =
    let module Hier = Hierarchy.In_scope (I)(O) in
    Hier.hierarchical ~scope ~name:"add_sub" create
  ;;

end

module Top = struct
  module I = struct
    type 'a t =
      { clock : 'a
      ; a : 'a array[@bits 8][@length 4]
      ; b : 'a array[@bits 8][@length 4]
      ; sel : 'a[@bits 4]
      }
    [@@deriving sexp_of, hardcaml]
  end
  module O = struct
    type 'a t =
      { c : 'a array[@bits 8][@length 4] }
    [@@deriving sexp_of, hardcaml]
  end

  open Signal

  let create scope (i : _ I.t) =
    { O.c = Array.init 4 ~f:(fun index ->
        (Add_sub.hierarchical scope { Add_sub.I.a = i.a.(index); b = i.b.(index); sel = i.sel.:(index) }).c
        |> reg (Reg_spec.create ~clock:i.clock ()))
    }
end

(* Commands for querying a hierarchical design *)

module Circ = Circuit.With_interface(Top.I)(Top.O)

let circ () =
  let scope = Scope.create ~flatten_design:false () in
  let circ = Circ.create_exn ~name:"top" (Top.create scope) in
  scope, circ
;;

let command_verilog =
  Command.basic
    ~summary:"Print verilog"
    [%map_open.Command
      let () = return () in
      fun () ->
        let scope, circ = circ () in
        Rtl.print ~database:(Scope.circuit_database scope) Verilog circ]

let database () =
  let scope, circ = circ () in
  let circs = circ :: (Scope.circuit_database scope |> Circuit_database.get_circuits) in
  List.map circs ~f:(fun circ ->
    Circuit.name circ, Circuit.signal_map circ)
;;

let command_print_database =
  Command.basic
    ~summary:"Print circuit database"
    [%map_open.Command
      let summary = flag "-summary" no_arg ~doc:" only print circuit names" in
      fun () ->
        let database = database () |> List.map ~f:(fun (n,d) -> n, Map.to_alist d) in
        if summary then
          print_s [%message (database : (string, _) List.Assoc.t)]
        else
          print_s [%message (database : (string, (Signal.Uid.t, Signal.t) List.Assoc.t) List.Assoc.t)]]
;;

let command_query =
  Command.basic
    ~summary:"Query circuit database"
    [%map_open.Command
      let name = anon ("CIRCUIT-NAME" %: string)
      and uid = anon ("UID" %: int)
      in
      fun () ->
        match List.Assoc.find (database()) name ~equal:String.equal with
        | None -> raise_s [%message "No such circuit"]
        | Some circuit ->
          match Map.find circuit (Int64.of_int uid) with
          | None -> raise_s [%message "No such uid in circuit"]
          | Some signal -> print_s [%message (signal : Signal.t)]]
;;

let () =
  Command_unix.run
    (Command.group
       ~summary:"example circuit"
       [ "verilog", command_verilog
       ; "print-database", command_print_database
       ; "query", command_query
       ])
;;

(*
$ test.exe query add_sub 2
(signal
 (wire
  (loc
   ((caller_id.ml:49:14) (signal.ml:371:16) (/home/andyman/test.ml:13:8)
    (circuit.ml:391:17) (hierarchy.ml:44:16) (/home/andyman/test.ml:59:8)
    (array0.ml:91:26) (/home/andyman/test.ml:58:12) (circuit.ml:392:18)
    (/home/andyman/test.ml:70:13) (/home/andyman/test.ml:84:20)
    (/home/andyman/test.ml:111:30) (command.ml:3239:12) (command.ml:3351:8)
    (exn.ml:129:6) (/home/andyman/test.ml:120:2)))
  (width 8) (data_in b)))
*)