Hierarchy in hardcaml, with optional flattening and automatic wiring of clock

test_hier2.ml

open HardCaml

(* different register types *)
module Seq = struct
  open Signal
  open Types
  open Seq
  module type S = sig
    include Interface.S
    val reg : Api.Comb.t t -> Signal.Types.register
  end
  module type T = sig
    include Seq
    val sys : (module S)
  end
  module Full = struct
    type 'a t = {
      clock : 'a[@bits 1];
      reset : 'a[@bits 1];
      clear : 'a[@bits 1];
    }[@@deriving hardcaml]
    let reg r = 
      { r_full with
        reg_clock = r.clock;
        reg_reset = r.reset;
        reg_clear = r.clear;
      }
  end
  module Async = struct
    type 'a t = {
      clock : 'a[@bits 1];
      reset : 'a[@bits 1];
    }[@@deriving hardcaml]
    let reg r = 
      { r_async with
        reg_clock = r.clock;
        reg_reset = r.reset;
      }
  end
  module Sync = struct
    type 'a t = {
      clock : 'a[@bits 1];
      clear : 'a[@bits 1];
    }[@@deriving hardcaml]
    let reg r = 
      { r_sync with
        reg_clock = r.clock;
        reg_clear = r.clear;
      }
  end
  module None = struct
    type 'a t = {
      clock : 'a[@bits 1];
    }[@@deriving hardcaml]
    let reg r = 
      { r_none with
        reg_clock = r.clock;
      }
  end
  let make reg r = 
    let module Seq = Make_seq(struct let reg_spec = reg r let ram_spec = r_none end) in
    (module Seq : Seq)
end

(**********************************************************************)

module type Inst_type = sig
  val inst_type : [ `flat | `inst | `hier of Circuit.Hierarchy.database ]
end

module Make_inst(T : Inst_type)(I : Interface.S)(O : Interface.S) = struct

  module Inst = Interface.Inst(I)(O)
  module Hier = Interface.Hier(I)(O) 

  let f name f i =
    match T.inst_type with
    | `flat -> f i
    | `inst -> Inst.make name i 
    | `hier(db) -> Hier.make db name f i

end

module Make_seq_inst(T : Inst_type)(S : Seq.S)(I : Interface.S)(O : Interface.S) = struct 

  module Isys = struct
    type 'a t = {
      sys : 'a S.t;
      i : 'a I.t;
    }[@@deriving hardcaml]
  end

  module Inst = Interface.Inst(Isys)(O)
  module Hier = Interface.Hier(Isys)(O) 

  let sys = S.(map (fun (n,b) -> Api.Comb.input n b) t)
  module Seq = (val (Seq.make S.reg sys))

  let f name f i =
    match T.inst_type with
    | `flat -> f i
    | `inst -> Inst.make name { Isys.sys = sys; i }
    | `hier(db) -> Hier.make db name (fun i -> f i.Isys.i) { Isys.sys = sys; i }

end

module Inst_type = struct
  module Hier() = struct 
    let db = Circuit.Hierarchy.empty ()
    let inst_type = `hier(db) 
  end
  module Flat = struct let inst_type = `flat end
  module Inst = struct let inst_type = `inst end
end

(**********************************************************************)

module Fa = struct

  module I = struct
    type 'a t = {
      a : 'a[@bits 1];
      b : 'a[@bits 1];
      cin : 'a[@bits 1]
    }[@@deriving hardcaml]
  end

  module O = struct
    type 'a t = {
      sum : 'a[@bits 1];
      cout : 'a[@bits 1];
    }[@@deriving hardcaml]
  end

  let name = "fulladder"

  open Api.Comb

  let f i = 
    let open I in
    let sum = i.a ^: i.b ^: i.cin in
    let cout = (i.a ^: i.b) |: (i.a ^: i.cin) |: (i.b ^: i.cin) in
    { O.sum; cout }

end

(* combinatorial carry ripple adder *)
module Carry_ripple(T : Inst_type) = struct

  module I = struct
    type 'a t = {
      a : 'a[@bits 8];
      b : 'a[@bits 8];
    }[@@deriving hardcaml]
  end

  module O = struct
    type 'a t = {
      c : 'a[@bits 9];
    }[@@deriving hardcaml]
  end

  let name = "carry_ripple_adder"

  module Fa_inst = Make_inst(T)(Fa.I)(Fa.O)

  let f i = 
    let open I in
    let open Api.Comb in
    let c, s = List.fold_left2 
        (fun (c,s) a b -> 
           let o = Fa_inst.f Fa.name Fa.f { Fa.I.a; b; cin=c} in 
           o.Fa.O.cout,o.Fa.O.sum::s)
      (gnd,[]) (List.rev (bits i.I.a)) (List.rev (bits i.I.b))
    in
    { O.c = concat (c::s) }

end

module Reg = struct
  module I = struct
    type 'a t = {
      d : 'a[@bits 9];
    }[@@deriving hardcaml]
  end

  module O = struct
    type 'a t = {
      q : 'a[@bits 9];
    }[@@deriving hardcaml]
  end

  let name = "sync_reg"

  module Make(Seq : Signal.Seq) = struct

    open Api.Comb

    let f i = 
      { O.q = Seq.reg ~e:vdd i.I.d }

  end
  
end

module AdderReg(T : Inst_type) = struct

  module Cra = Carry_ripple(T)
  module Cra_inst = Make_inst(T)(Cra.I)(Cra.O)

  module I = Cra.I
  module O = Reg.O

  module Reg_inst = Make_seq_inst(T)(Seq.Full)(Reg.I)(Reg.O) 

  let name = "adder_reg"

  let f i = 
    (* construct carry ripple adder *)
    let o = Cra_inst.f Cra.name Cra.f i in

    (* register *)
    let module Reg' = Reg.Make(Reg_inst.Seq) in
    Reg_inst.f Reg.name Reg'.f { Reg.I.d = o.Cra.O.c }

end


module H = Inst_type.Hier()
module A = AdderReg(H)
module Circ = Interface.Circ(A.I)(A.O)
module A_inst = Make_seq_inst(H)(Seq.Full)(A.I)(A.O)
let circ = Circ.make "top" (A_inst.f A.name A.f)
let rtlh() = Rtl.Hierarchy.write H.db "" (fun _ -> Rtl.Verilog.write print_string) circ


module F = Inst_type.Flat
module Aflat = AdderReg(F)
module Aflat_inst = Make_seq_inst(F)(Seq.Full)(Aflat.I)(Aflat.O)
module Circ = Interface.Circ(Aflat.I)(Aflat.O)
let circ = Circ.make "top" (Aflat_inst.f Aflat.name Aflat.f)
let rtlf() = Rtl.Verilog.write print_string circ