1
(* This file is part of Marionnet, a virtual network laboratory
2
Copyright (C) 2009 Jean-Vincent Loddo
3
Copyright (C) 2009 Université Paris 13
5
This program is free software: you can redistribute it and/or modify
6
it under the terms of the GNU General Public License as published by
7
the Free Software Foundation, either version 2 of the License, or
8
(at your option) any later version.
10
This program is distributed in the hope that it will be useful,
11
but WITHOUT ANY WARRANTY; without even the implied warranty of
12
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13
GNU General Public License for more details.
15
You should have received a copy of the GNU General Public License
16
along with this program. If not, see <http://www.gnu.org/licenses/>. *)
19
open Camlp4 (* -*- camlp4o -*- *)
21
(* ocamlc -I +camlp4 -pp camlp4of.opt camlp4lib.cma chip_parser.p4.ml *)
23
(* For a strange bug, Camlp4of goes in a loop (StackOverflow) when a chip
24
with more than 1 port is declared virtual. Thus, in practice, if the chip
25
is virtual, we are limited to 1 port! *)
29
let version = "$Id: chip_pa.ml,v 0.1 2009/02/16 16:16:16 $"
32
module Make (Syntax : Sig.Camlp4Syntax) = struct
36
(* Make a multiple application. *)
37
let apply _loc f xs = List.fold_left (fun f x -> <:expr< $f$ $x$>>) f xs
39
(* Make a string list ast from... a string list. *)
40
let rec string_list_of_string_list _loc = function
42
| x::xs -> let xs' = string_list_of_string_list _loc xs in <:expr< $str:x$ :: $xs'$>>
44
let rec expr_of_expr_list _loc = function
46
| x::xs -> let xs' = expr_of_expr_list _loc xs in <:expr< $x$ :: $xs'$>>
48
(* Make a multiple abstraction to a class_expr. *)
49
let lambda_class_expr _loc xs body = List.fold_right (fun x b -> <:class_expr< fun $x$ -> $b$>>) xs body
51
(* Make a multiple abstraction to a type. *)
52
let lambda_ctyp _loc xs body = List.fold_right (fun x b -> <:ctyp< $x$ -> $b$>>) xs body
54
(* Make a fresh identifier (string). *)
55
let fresh_var_name ~blacklist ~prefix =
57
let candidate = (prefix^(string_of_int n)) in
58
if not (List.mem candidate blacklist) then candidate else loop (n+1)
60
if (List.mem prefix blacklist) then (loop 0) else prefix
62
let fresh_var_names ~blacklist ~prefixes =
63
let r = List.fold_left (fun l p -> (fresh_var_name ~blacklist:(l@blacklist) ~prefix:p) :: l) [] prefixes in
66
(* List.combine for 3 lists *)
67
let rec combine3 l1 l2 l3 = match (l1,l2,l3) with
69
| x1::r1, x2::r2, x3::r3 -> (x1,x2,x3)::(combine3 r1 r2 r3)
70
| _ -> raise (Invalid_argument "combine3")
72
let rec combine4 l1 l2 l3 l4 = match (l1,l2,l3,l4) with
73
| [] , [] , [] , [] -> []
74
| x1::r1, x2::r2, x3::r3, x4::r4 -> (x1,x2,x3,x4)::(combine4 r1 r2 r3 r4)
75
| _ -> raise (Invalid_argument "combine4")
77
(* Check unicity in a string list. Raises a failure with the duplicated string. *)
78
let rec check_unicity = function
80
| x::r -> if (List.mem x r) then failwith ("Duplicated port name '"^x^"'")
81
else (check_unicity r)
88
[ [ "complement"; w = LIST0 class_str_item ; "end" -> w ] ] ;
91
[ [ "("; x = LIDENT ; ":"; t = ctyp; ")" -> (x, Some t)
92
| x = LIDENT ; ":"; t = ctyp -> (x, Some t)
93
| x = LIDENT -> (x, None ) ] ] ;
96
[ [ "chip"; virt = OPT "virtual"; class_name = LIDENT; user_parameters = LIST0 [ x=patt -> x]; ":" ;
98
input_ports = [ "(" ; l = LIST0 [ x = port_ident -> x] SEP ","; ")" -> l ];
100
output_ports = [ "->"; "("; l = LIST0 [ x = port_ident -> x] SEP "," ; ")"; "=" -> l
101
| "->"; "unit"; "=" -> []
104
e = expr ; w = OPT where ->
107
let is_virtual = (virt <> None) in
109
(* Are there where clauses: *)
110
let user_complement_section = match w with None -> [] | Some w -> w in
112
(* Port names (inputs + outputs) *)
113
let is_source = (input_ports = []) in
114
let inputs = List.map fst input_ports in
115
let outputs = List.map fst output_ports in
116
let port_names = List.append inputs outputs in
117
let () = check_unicity port_names in
119
let ancestor = match input_ports, output_ports with
120
| [],[] -> failwith "Autistic chips not allowed!"
126
(* Support functions and values *)
128
let set_alone_application a = <:expr< self#$lid:"set_alone_" ^a$ $lid:a$ >> in
129
let connect_application a = <:expr< self#$lid:"connect_" ^a$ $lid:a$ >> in
130
let disconnect_application a = <:expr< self#$lid:"disconnect_"^a$ >> in
133
let str = (fresh_var_name ~blacklist:port_names ~prefix:"w") in
134
(<:patt< $lid:str$ >> , <:expr< $lid:str$ >>)
138
let str = (fresh_var_name ~blacklist:port_names ~prefix:"v") in
139
(<:patt< $lid:str$ >> , <:expr< $lid:str$ >>)
143
let str = (fresh_var_name ~blacklist:port_names ~prefix:"s") in
144
(<:patt< $lid:str$ >> , <:expr< $lid:str$ >>)
147
(* Class type variables *)
149
let type_variables = List.map (fun i -> <:ctyp< '$lid:i$ >>) port_names in
150
Ast.tyCom_of_list type_variables
153
(* Inherit section *)
154
let inherit_section = [ <:class_str_item< inherit $lid:ancestor$ ?name system >> ] in
156
(* Tool for creating a pattern depending on the length of a list of identifiers
157
encoded by strings. If the list is empty, the pattern () is built. If the list is
158
a singleton, the pattern is simply itself. If the list has almost two elements,
159
a tuple pattern is created. *)
160
let pattern_of_string_list = function
161
| [] -> <:patt< () >>
162
| [x] -> <:patt< $lid:x$>>
163
| l -> Ast.PaTup (_loc, Ast.paCom_of_list (List.map (fun x-> <:patt< $lid:x$>>) l))
166
(* Similar to pattern_of_string_list, but for making an expression from a list of
168
let expression_of_expr_list = function
169
| [] -> <:expr< () >>
171
| l -> Ast.ExTup (_loc, Ast.exCom_of_list l)
174
let type_of_ctyp_list = function
175
| [] -> <:ctyp< unit >>
177
| l -> Ast.TyTup (_loc, Ast.tySta_of_list l)
180
(* Firmware section *)
184
fun (x,ot) -> match ot with None -> Ast.TyLab(_loc,x,<:ctyp< _ >>) | Some t -> Ast.TyLab(_loc,x,t) in
185
List.map mill input_ports
189
let mill = fun (_,ot) -> match ot with None -> <:ctyp< _ >> | Some t -> t in
190
type_of_ctyp_list (List.map mill output_ports)
193
let signature = lambda_ctyp _loc domains codomain in
196
let pl = List.map (fun i -> Ast.PaLab (_loc, i, <:patt< >>)) inputs in
197
let firmware_expr = List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e in
198
let firmware_method =
200
| false -> <:class_str_item< method firmware : $signature$ = $firmware_expr$ >>
201
| true -> <:class_str_item< method firmware = $firmware_expr$ >>
206
(* in_port fields section *)
208
let mill a = <:class_str_item< val mutable $lid:a$ = in_port_of_wire_option $lid:a$ >> in
212
(* out_port fields section *)
213
let out_port_fields =
214
let mill x = <:class_str_item< val mutable $lid:x$ = out_port_of_wire_option $lid:x$ >> in
215
List.map mill outputs
218
let port_names_fields =
219
let in_port_names = string_list_of_string_list _loc inputs in
220
let out_port_names = string_list_of_string_list _loc outputs in
221
[ <:class_str_item< val in_port_names = $in_port_names$ >> ;
222
<:class_str_item< val out_port_names = $out_port_names$ >> ]
225
(* connect_? methods for input ports *)
228
let b = fresh_var_name ~blacklist:port_names ~prefix:a in
229
let tv = <:ctyp< '$lid:a$ >> in
230
let tv'= <:ctyp< '$lid:b$ >> in
231
let t = <:ctyp< ($tv'$,$tv$) wire -> unit >> in
232
let method_type = Ast.TyPol (_loc, Ast.TyQuo(_loc,b), t) in
233
<:class_str_item< method $lid:"connect_"^a$ : $method_type$ = function $pat_w$ -> ($lid:a$ <- in_port_of_wire $exp_w$) >> in
237
(* connect_? methods for output ports *)
240
let b = fresh_var_name ~blacklist:port_names ~prefix:a in
241
let tv = <:ctyp< '$lid:a$ >> in
242
let tv'= <:ctyp< '$lid:b$ >> in
243
let t = <:ctyp< ($tv$,$tv'$) wire -> unit >> in
244
let method_type = Ast.TyPol (_loc, Ast.TyQuo(_loc,b), t) in
245
<:class_str_item< method $lid:"connect_"^a$ : $method_type$ = function $pat_w$ -> ($lid:a$ <- out_port_of_wire $exp_w$) >> in
246
List.map mill outputs
251
let ivl = fresh_var_names ~blacklist:port_names ~prefixes:inputs in
252
let ovl = fresh_var_names ~blacklist:(port_names@ivl) ~prefixes:outputs in
254
let va = <:ctyp< '$lid:a$ >> in
255
let vb = <:ctyp< '$lid:b$ >> in
256
<:ctyp< ($va$,$vb$) wire >>
258
let it = type_of_ctyp_list (List.map2 wire_type ivl inputs) in
259
let ot = type_of_ctyp_list (List.map2 wire_type outputs ovl) in
260
let qivl = List.map (fun x -> Ast.TyQuo(_loc,x)) ivl in
261
let qovl = List.map (fun x -> Ast.TyQuo(_loc,x)) ovl in
262
let pi = pattern_of_string_list inputs in
263
let po = pattern_of_string_list outputs in
264
let connect_actions = Ast.exSem_of_list (List.map connect_application port_names) in
265
match inputs, outputs with
266
| [] , [] -> assert false
268
let i_forall_vars = List.fold_left (fun x y -> Ast.TyApp (_loc,x,y)) (List.hd qivl) (List.tl qivl) in
269
let method_type = Ast.TyPol (_loc, i_forall_vars, <:ctyp< $it$ -> unit>>) in
270
[ <:class_str_item< method connect : $method_type$ = function $pi$ -> begin $connect_actions$ end >> ]
273
let o_forall_vars = List.fold_left (fun x y -> Ast.TyApp (_loc,x,y)) (List.hd qovl) (List.tl qovl) in
274
let method_type = Ast.TyPol (_loc, o_forall_vars, <:ctyp< $ot$ -> unit>>) in
275
[ <:class_str_item< method connect : $method_type$ = function $po$ -> begin $connect_actions$ end >> ]
278
let qvl = List.append qivl qovl in
279
let forall_vars = List.fold_left (fun x y -> Ast.TyApp (_loc,x,y)) (List.hd qvl) (List.tl qvl) in
280
let method_type = Ast.TyPol (_loc, forall_vars, <:ctyp< $it$ -> $ot$ -> unit>>) in
281
[ <:class_str_item< method connect : $method_type$ = function $pi$ -> function $po$ -> begin $connect_actions$ end >> ]
284
(* disconnect_? methods for all ports *)
286
let mill a = <:class_str_item< method $lid:"disconnect_"^a$ = $lid:a$ <- None >> in
287
List.map mill port_names
290
(* disconnect method *)
292
let disconnect_actions = Ast.exSem_of_list (List.map disconnect_application port_names)
296
begin $disconnect_actions$ end
301
(* get_wire_? methods for input ports *)
304
let str = <:expr< $str:class_name^"#get_wire_"^a$ >> in
305
<:class_str_item< method $lid:"get_wire_"^a$ = fst_of_triple (extract ~caller:$str$ $lid:a$) >> in
309
(* get_wire_? methods for output ports *)
312
let str = <:expr< $str:class_name^"#get_wire_"^a$ >> in
313
<:class_str_item< method $lid:"get_wire_"^a$ = extract ~caller:$str$ $lid:a$ >> in
314
List.map mill outputs
317
let get_wire_connections =
320
<:expr< ($str:a$, wire_as_common_option_of_in_port $lid:a$) >> in
325
<:expr< ($str:a$, wire_as_common_option_of_out_port $lid:a$) >> in
326
List.map mill outputs
328
let il = expr_of_expr_list _loc connections_i in
329
let ol = expr_of_expr_list _loc connections_o in
330
[ <:class_str_item< method $lid:"input_wire_connections"$ = $il$ >> ;
331
<:class_str_item< method $lid:"output_wire_connections"$ = $ol$ >> ]
334
(* set_in_port_? methods *)
337
<:class_str_item< method $lid:"set_in_port_"^a$ $pat_w$ $pat_v$ $pat_s$ = $lid:a$ <- Some ($exp_w$,(Some $exp_v$),$exp_s$) >> in
341
(* set_alone_? methods for input ports *)
344
let str = <:expr< $str:class_name^"#set_alone_"^a$ >> in
345
<:class_str_item< method $lid:"set_alone_"^a$ $pat_v$ = (fst (extract ~caller:$str$ $lid:a$))#set_alone $exp_v$ >> in
349
(* set_alone_? methods for output ports *)
352
let str = <:expr< $str:class_name^"#set_alone_"^a$ >> in
353
<:class_str_item< method $lid:"set_alone_"^a$ v = (extract ~caller:$str$ $lid:a$)#set_alone v >> in
354
List.map mill outputs
357
(* stabilize method section *)
359
let str = <:expr< $str:class_name^"#stabilize"$ >> in
361
let winputs = List.map (fun a -> fresh_var_name ~blacklist:port_names ~prefix:("w"^a)) inputs in
362
let unchanged_inputs = List.map (fun a -> fresh_var_name ~blacklist:port_names ~prefix:("unchanged_"^a)) inputs in
363
let sensitiveness_inputs = List.map (fun a -> fresh_var_name ~blacklist:port_names ~prefix:("sens_"^a)) inputs in
366
let mill (wa,a,sa,unchanged_a) =
367
let p = <:patt< ($lid:wa$, $lid:a$ , $lid:sa$ , $lid:unchanged_a$) >> in
368
<:binding< $p$ = (extract_and_compare $str$ $lid:"equality"$ $lid:a$) >>
369
in Ast.biAnd_of_list (List.map mill (combine4 winputs inputs sensitiveness_inputs unchanged_inputs))
373
let l = (List.map (fun unchanged_a -> <:expr< $lid:unchanged_a$ >>) unchanged_inputs) in
374
List.fold_right (fun e1 e2 -> <:expr< $e1$ && $e2$ >>) l <:expr< true >>
377
let output_bindings =
378
let inputs_as_lid_expressions = List.map (fun x -> <:expr< $lid:x$>>) inputs in
379
let firmware_application = apply _loc <:expr< self#firmware>> inputs_as_lid_expressions in
380
let output_pattern = pattern_of_string_list outputs in
381
<:binding< $output_pattern$ = $firmware_application$ >>
385
let set_in_port_application (wa,a,sa) = <:expr< self#$lid:"set_in_port_"^a$ $lid:wa$ $lid:a$ $lid:sa$ >> in
386
Ast.exSem_of_list ((List.map set_in_port_application (combine3 winputs inputs sensitiveness_inputs))
387
@(List.map set_alone_application outputs))
391
method stabilize : performed =
392
let $binding:input_bindings$ in
393
if ($unchanged_test$)
397
let $binding:output_bindings$ in
404
(* emit method section (for sources) *)
407
let arg = fresh_var_name ~blacklist:port_names ~prefix:"arg" in
409
let output_bindings =
410
let inputs_as_lid_expressions = List.map (fun x -> <:expr< $lid:x$>>) inputs in
411
let firmware_application = apply _loc <:expr< self#firmware $lid:arg$ >> inputs_as_lid_expressions in
412
let output_pattern = pattern_of_string_list outputs in
413
<:binding< $output_pattern$ = $firmware_application$ >>
416
let set_actions = Ast.exSem_of_list (List.map set_alone_application outputs)
420
method emit $lid:arg$ =
422
let $binding:output_bindings$ in
424
self#system#stabilize
425
in self#system#mutex_methods#with_mutex actions
430
(* set method section *)
432
let input_pattern = pattern_of_string_list inputs in
433
let set_alone_actions = Ast.exSem_of_list (List.map set_alone_application inputs)
436
method set $input_pattern$ =
437
$set_alone_actions$ ;
438
self#system#stabilize
443
(* get method section (outputs) *)
446
let str = <:expr< $str:class_name^"#get (reading "^a^")"$ >> in
447
<:expr< (extract ~caller:$str$ $lid:a$)#get_alone >> in
448
let output_expression = expression_of_expr_list (List.map mill outputs)
449
in [ <:class_str_item< method get = $output_expression$ >> ]
453
(* get_? methods for inputs *)
456
let str = <:expr< $str:class_name^"#get_"^a$ >> in
457
<:class_str_item< method $lid:"get_"^a$ = (fst_of_triple (extract ~caller:$str$ $lid:a$))#get_alone >> in
461
(* get_? methods for outputs *)
464
let str = <:expr< $str:class_name^"#get_"^a$ >> in
465
<:class_str_item< method $lid:"get_"^a$ = (extract ~caller:$str$ $lid:a$)#get_alone >> in
466
List.map mill outputs
469
(* Merging sections *)
470
let cst = Ast.crSem_of_list
484
get_wire_connections;
491
if is_source then emit else stabilize ;
492
(* if is_source then [] else set ;*)
493
user_complement_section ;
497
(* Class expression *)
501
fun ?(system : system = (Chip.get_or_initialize_current_system ())) () -> object (self) $cst$ end >> in
503
(* Class expression with optional parameters *)
504
let cop_list = List.map (fun i -> Ast.PaOlb (_loc, i, <:patt< >>)) port_names in
505
let cewop = List.fold_right (fun op ce -> <:class_expr< fun $op$ -> $ce$ >>) cop_list ce in
506
let cewop = <:class_expr< fun ?name ?(equality=(Pervasives.(=))) -> $cewop$ >> in
507
let cewop_with_user_parameters = lambda_class_expr _loc user_parameters cewop in
508
let internal_module_name = ("Chip_class_definition_"^class_name) in
509
let class_def = match is_virtual with
510
| false -> <:str_item< class [ $ctv$ ] $lid:class_name$ = $cewop_with_user_parameters$ >>
511
| true -> <:str_item< class virtual [ $ctv$ ] $lid:class_name$ = $cewop_with_user_parameters$ >>
515
module $uid:internal_module_name$ = struct
519
include $uid:internal_module_name$
529
let module M = Register.OCamlSyntaxExtension (Id) (Make) in ()
added
removed
chip/chip_parser_p4.old_version.ml
