/shdl_repr.ml

  1open Shdl_types
  2
  3(* Internal representation *)
  4
  5module Ctx =
  6  struct
  7    type value = bool
  8
  9    and index = string
 10
 11    and element = User of (t option -> value list -> value list)
 12                | Base of (unit -> value list -> value list)
 13                | Variable of value list
 14
 15    and t = {
 16      dict   : (index, element) Hashtbl.t ;
 17      parent : t option ;
 18    }
 19
 20    exception Index_not_found of index
 21    exception Box_needed of index
 22    exception Variable_needed of index
 23    exception Overriding_error of index
 24    exception Undeclared_error of index
 25    exception Out_of_bound_error of index * int
 26
 27    let create size parent =
 28      { dict = Hashtbl.create size ; parent = parent }
 29
 30    let rec lookup t idx =
 31      try
 32        Hashtbl.find t.dict idx
 33      with Not_found ->
 34        begin
 35          match t.parent with
 36          | None -> raise (Index_not_found(idx))
 37          | Some p -> lookup p idx
 38        end
 39
 40    let register t idx elem =
 41      if Hashtbl.mem t.dict idx then
 42        raise (Overriding_error idx)
 43      else
 44        Hashtbl.add t.dict idx elem
 45
 46    let register_base t idx gen = register t idx (Base gen)
 47
 48    let register_user t idx gen = register t idx (User gen)
 49
 50    let declare = 
 51      let rec make_var size acc =
 52        if size = 0 then Variable(acc)
 53        else make_var (size-1) (false::acc)
 54      in
 55      fun t size idx ->
 56        let elem = (make_var size []) in
 57        register t idx elem
 58
 59
 60    let instanciate t idx =
 61      match lookup t idx with
 62      | User gen -> gen (Some t)
 63      | Base gen -> gen ()
 64      | other -> raise (Box_needed idx)
 65
 66    let assign t idx content =
 67      if Hashtbl.mem t.dict idx then
 68        let elem = Variable content in
 69        let _ = Hashtbl.replace t.dict idx elem in
 70        content
 71      else
 72        raise (Undeclared_error idx)
 73
 74    let assign_one =
 75      let rec replace l nth v acc =
 76        match nth, l with
 77        | 0, h::r -> (List.rev (v::acc))@r
 78        | n, h::r -> replace r (n-1) v (h::acc)
 79        | _       -> raise (Invalid_argument "")
 80      in
 81      fun t idx n value ->
 82        try
 83          match Hashtbl.find t.dict idx with
 84          | Variable vl ->
 85              Hashtbl.replace t.dict idx (Variable (replace vl n value []))
 86          | _ -> raise (Variable_needed idx)
 87        with
 88        | Not_found -> raise (Undeclared_error idx)
 89        | Invalid_argument _ -> raise (Out_of_bound_error (idx, n))
 90
 91
 92    let input =
 93      let rec sublist start size l acc =
 94        match start, size, l with
 95        | (0, n, h::t) when n > 0 -> sublist 0 (n-1) t (h::acc)
 96        | (n, _, h::t) when n > 0 -> sublist (n-1) size t acc
 97        | _                       -> List.rev acc
 98      in
 99      fun t inputs start size idx ->
100        let content = sublist start size inputs [] in
101        assign t idx content
102      
103    let print t =
104      Hashtbl.iter
105        ( fun idx elem -> match elem with
106            | Variable vl ->
107              begin
108                print_string ("var" ^ " : " ^ idx ^ " : ") ;
109                List.iter
110                  ( fun b -> print_string ((string_of_bool b) ^ ";") )
111                  vl ;
112                print_newline ()
113              end
114            | _ -> print_endline ("box : " ^ idx) )
115        t.dict
116  end
117
118(* Examples *)
119
120let toplevel = Ctx.create 10 None
121
122let not_box =
123  let not_base = fun inputs -> List.map ( fun b -> not b ) inputs in
124  fun () -> not_base
125
126let _ = Ctx.register_base toplevel "not" not_box
127
128let and_box =
129  let and_base = fun inputs -> [List.for_all ( fun b -> b ) inputs] in
130  fun () -> and_base
131
132let _ = Ctx.register_base toplevel "and" and_box
133
134let or_box =
135  let or_base = fun inputs -> [List.exists ( fun b -> b ) inputs] in
136  fun () -> or_base
137
138let _ = Ctx.register_base toplevel "or" or_box
139(*
140let mux parent =
141  let ctx = Ctx.create 5 parent in
142  let _ = Ctx.declare ctx 1 "x"
143  and _ = Ctx.declare ctx 1 "y"
144  and _ = Ctx.declare ctx 1 "o"
145  and _ = Ctx.declare ctx 2 "a"
146  and _ = Ctx.declare ctx 1 "sel"
147  and f_1 = Ctx.instanciate ctx "and"
148  and f_2 = Ctx.instanciate ctx "not"
149  and f_3 = Ctx.instanciate ctx "and"
150  and f_4 = Ctx.instanciate ctx "or" in
151  fun ins ->
152    (* inputs *)
153    let a   = Ctx.input ctx ins 0 2 "a"
154    and sel = Ctx.input ctx ins 2 1 "sel" in
155    (* definitions *)
156    let x   = Ctx.assign ctx "x" ( f_1 ([] @ (f_2 sel) @ [List.nth a 0] ) ) in
157    let y   = Ctx.assign ctx "y" ( f_3 ([] @ sel @ [List.nth a 1] ) ) in
158    let o   = Ctx.assign ctx "o" ( f_4 ([] @ x @ y ) ) in
159    (* result *)
160    [] @ o
161
162let _ = Ctx.register_user toplevel "mux" mux
163*)
164(** Generation part **)
165
166type pos = int
167
168type ident_repr = Ctx.index * pos option
169
170type expr_repr = Repr_b of bool
171               | Repr_v of ident_repr
172               | Repr_c of (Ctx.value list -> Ctx.value list) * expr_repr list
173
174type def_repr = Repr_d of ident_repr * expr_repr
175
176(* Inputs helper *)
177let inputs_fn ctx inputs (Ident(n,s)) ptr =
178  let _ = Ctx.input ctx inputs ptr s n in
179  ptr + s
180
181(* Definition helpers *)
182let convert_ident (Ident(n,s)) = (n, if s > 0 then Some s else None)
183
184let convert_expr n_translator =
185  let rec aux = function
186    | Call(n,exprs) -> Repr_c(n_translator n, List.map aux exprs)
187    | Boolean b -> Repr_b b
188    | Value(i) -> Repr_v (convert_ident i)
189  in
190  aux
191
192let convert_defs n_translator defs =
193  List.map
194    ( fun (Definition(i,e)) ->
195      Repr_d(convert_ident i, convert_expr n_translator e) )
196    defs
197
198let expr_eval ctx =
199  let rec aux = function
200    | Repr_b b -> [b]
201    | Repr_v(idx, pos) ->
202      begin
203        match Ctx.lookup ctx idx with
204        | Ctx.Variable vl ->
205          begin
206            match pos with
207            | None -> vl
208            | Some n -> [List.nth vl n]
209          end
210        | _ -> raise (Ctx.Variable_needed idx)
211      end
212    | Repr_c(f, inputs) -> f (List.flatten (List.map aux inputs))
213  in
214  fun expr -> aux expr
215  
216let def_eval ctx (Repr_d((idx,pos), expr)) =
217  match pos with
218  | None -> ignore (Ctx.assign ctx idx (expr_eval ctx expr))
219  | Some n -> Ctx.assign_one ctx idx n (List.hd (expr_eval ctx expr))
220
221let generate_box box =
222  let Box(_, ins, outs, vars, defs) = box in
223  let all_ident = List.flatten [ins ; outs ; vars] in
224  let ident_asc = List.map (fun (Ident(n,s)) -> (n,s)) all_ident in
225  let ctx_size = List.fold_left (fun sum (_, a) -> sum + a) 0 ident_asc in
226  
227  fun parent ->
228    let ctx = Ctx.create ctx_size parent in
229    (* Declarations *)
230    List.iter ( fun (n,s) -> Ctx.declare ctx s n ) ident_asc ;
231    let defs_r = convert_defs ( fun call -> Ctx.instanciate ctx call ) defs in
232    (* TODO: Get aux box *)
233    fun inputs ->
234      (* TODO: Inputs *)
235      let _ = List.fold_right (inputs_fn ctx inputs) ins 0 in
236      (* TODO: Definitions *)
237      List.iter (def_eval ctx) defs_r ; 
238      (* TODO: Ouputs *)
239      List.fold_left
240        ( fun acc (Ident(n,_)) ->
241          acc@(expr_eval ctx (Repr_v(n, None))) )
242        []
243        outs