/shdl_repr.ml
OCaml | 243 lines | 177 code | 40 blank | 26 comment | 6 complexity | bbb48079839d24f7914378f77d200b1d MD5 | raw file
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