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
4
Applied an OCaml 3.12 compatibility patch by Clément Démoulins in 2011
6
This program is free software: you can redistribute it and/or modify
7
it under the terms of the GNU General Public License as published by
8
the Free Software Foundation, either version 2 of the License, or
9
(at your option) any later version.
11
This program is distributed in the hope that it will be useful,
12
but WITHOUT ANY WARRANTY; without even the implied warranty of
13
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14
GNU General Public License for more details.
16
You should have received a copy of the GNU General Public License
17
along with this program. If not, see <http://www.gnu.org/licenses/>. *)
20
open Camlp4 (* -*- camlp4o -*- *)
22
(* ocamlc -I +camlp4 -pp camlp4of.opt camlp4lib.cma chip_parser.p4.ml *)
24
(* For a strange bug, Camlp4of goes in a loop (StackOverflow) when a chip
25
with more than 1 port is declared virtual. Thus, in practice, if the chip
26
is virtual, we are limited to 1 port! *)
30
let version = "$Id: chip_pa.ml,v 0.1 2009/02/16 16:16:16 $"
33
module Make (Syntax : Sig.Camlp4Syntax) = struct
37
(* Make a multiple application. *)
38
let apply _loc f xs = List.fold_left (fun f x -> <:expr< $f$ $x$>>) f xs
40
(* Make a string list ast from... a string list. *)
41
let rec string_list_of_string_list _loc = function
43
| x::xs -> let xs' = string_list_of_string_list _loc xs in <:expr< $str:x$ :: $xs'$>>
45
let rec expr_of_expr_list _loc = function
47
| x::xs -> let xs' = expr_of_expr_list _loc xs in <:expr< $x$ :: $xs'$>>
49
(* Make a multiple abstraction to a class_expr. *)
50
let lambda_class_expr _loc xs body = List.fold_right (fun x b -> <:class_expr< fun $x$ -> $b$>>) xs body
52
(* Make a multiple abstraction to a type. *)
53
let lambda_ctyp _loc xs body = List.fold_right (fun x b -> <:ctyp< ($x$ -> $b$)>>) xs body
55
(* Make a fresh identifier (string). *)
56
let fresh_var_name ~blacklist ~prefix =
58
let candidate = (prefix^(string_of_int n)) in
59
if not (List.mem candidate blacklist) then candidate else loop (n+1)
61
if (List.mem prefix blacklist) then (loop 0) else prefix
63
let fresh_var_names ~blacklist ~prefixes =
64
let r = List.fold_left (fun l p -> (fresh_var_name ~blacklist:(l@blacklist) ~prefix:p) :: l) [] prefixes in
67
(* List.combine for 3 lists *)
68
let rec combine3 l1 l2 l3 = match (l1,l2,l3) with
70
| x1::r1, x2::r2, x3::r3 -> (x1,x2,x3)::(combine3 r1 r2 r3)
71
| _ -> raise (Invalid_argument "combine3")
73
let rec combine4 l1 l2 l3 l4 = match (l1,l2,l3,l4) with
74
| [] , [] , [] , [] -> []
75
| x1::r1, x2::r2, x3::r3, x4::r4 -> (x1,x2,x3,x4)::(combine4 r1 r2 r3 r4)
76
| _ -> raise (Invalid_argument "combine4")
78
(* Check unicity in a string list. Raises a failure with the duplicated string. *)
79
let rec check_unicity = function
81
| x::r -> if (List.mem x r) then failwith ("Duplicated port name '"^x^"'")
82
else (check_unicity r)
89
[ [ "complement"; w = LIST0 class_str_item ; "end" -> w ] ] ;
92
[ [ "("; x = LIDENT ; ":"; t = ctyp; ")" -> (x, Some t)
93
| x = LIDENT ; ":"; t = ctyp -> (x, Some t)
94
| x = LIDENT -> (x, None ) ] ] ;
97
[ [ "chip"; virt = OPT "virtual"; class_name = LIDENT; user_parameters = LIST0 [ x=patt -> x]; ":" ;
99
input_ports = [ "(" ; l = LIST0 [ x = port_ident -> x] SEP ","; ")" -> l ];
101
output_ports = [ "->"; "("; l = LIST0 [ x = port_ident -> x] SEP "," ; ")"; "=" -> l
102
| "->"; "unit"; "=" -> []
105
e = expr ; w = OPT where ->
108
let is_virtual = (virt <> None) in
110
(* Are there where clauses: *)
111
let user_complement_section = match w with None -> [] | Some w -> w in
113
(* Port names (inputs + outputs) *)
114
let is_source = (input_ports = []) in
115
let inputs = List.map fst input_ports in
116
let outputs = List.map fst output_ports in
117
let port_names = List.append inputs outputs in
118
let () = check_unicity port_names in
120
let ancestor = match input_ports, output_ports with
121
| [],[] -> failwith "Autistic chips not allowed!"
127
(* Support functions and values *)
129
let set_alone_application a = <:expr< self#$lid:"set_alone_" ^a$ $lid:a$ >> in
130
let connect_application a = <:expr< self#$lid:"connect_" ^a$ $lid:a$ >> in
131
let disconnect_application a = <:expr< self#$lid:"disconnect_"^a$ >> in
133
(* Class type variables *)
135
let type_variables = List.map (fun i -> <:ctyp< '$lid:i$ >>) port_names in
136
Ast.tyCom_of_list type_variables
139
(* Inherit section *)
140
let inherit_section = [ <:class_str_item< inherit $lid:ancestor$ ?name system >> ] in
142
(* Tool for creating a pattern depending on the length of a list of identifiers
143
encoded by strings. If the list is empty, the pattern () is built. If the list is
144
a singleton, the pattern is simply itself. If the list has almost two elements,
145
a tuple pattern is created. *)
146
let pattern_of_string_list = function
147
| [] -> <:patt< () >>
148
| [x] -> <:patt< $lid:x$>>
149
| l -> Ast.PaTup (_loc, Ast.paCom_of_list (List.map (fun x-> <:patt< $lid:x$>>) l))
152
let type_of_ctyp_list = function
153
| [] -> <:ctyp< unit >>
155
| l -> Ast.TyTup (_loc, Ast.tySta_of_list l)
158
(* Firmware section *)
162
fun (x,ot) -> match ot with None -> Ast.TyLab(_loc,x,<:ctyp< _ >>) | Some t -> Ast.TyLab(_loc,x,t) in
163
List.map mill input_ports
167
let mill = fun (_,ot) -> match ot with None -> <:ctyp< _ >> | Some t -> t in
168
type_of_ctyp_list (List.map mill output_ports)
171
let signature = lambda_ctyp _loc domains codomain in
174
let pl = List.map (fun i -> Ast.PaLab (_loc, i, <:patt< >>)) inputs in
175
let firmware_expr = List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e in
176
let firmware_method =
178
| false -> <:class_str_item< method firmware : $signature$ = $firmware_expr$ >>
179
| true -> <:class_str_item< method firmware = $firmware_expr$ >>
184
(* in_port fields section *)
186
let mill a = <:class_str_item< val $lid:a$ = (new in_port ~name:$str:a$ ?wire:$lid:a$ ()) >> in
190
(* out_port fields section *)
191
let out_port_fields =
192
let mill x = <:class_str_item< val $lid:x$ = (let wire = $lid:x$ in new out_port ~name:$str:x$ ?wire ()) >> in
193
List.map mill outputs
196
let port_names_fields =
197
let in_port_names = string_list_of_string_list _loc inputs in
198
let out_port_names = string_list_of_string_list _loc outputs in
199
[ <:class_str_item< val in_port_names = $in_port_names$ >> ;
200
<:class_str_item< val out_port_names = $out_port_names$ >> ]
203
(* connect_? methods for input ports *)
206
let b = fresh_var_name ~blacklist:port_names ~prefix:a in
207
let tv = <:ctyp< '$lid:a$ >> in
208
let tv'= <:ctyp< '$lid:b$ >> in
209
let t = <:ctyp< ($tv'$,$tv$) wire -> unit >> in
210
let method_type = Ast.TyPol (_loc, Ast.TyQuo(_loc,b), t) in
211
<:class_str_item< method $lid:"connect_"^a$ : $method_type$ = $lid:a$#connect >> in
215
(* connect_? methods for output ports *)
218
let b = fresh_var_name ~blacklist:port_names ~prefix:a in
219
let tv = <:ctyp< '$lid:a$ >> in
220
let tv'= <:ctyp< '$lid:b$ >> in
221
let t = <:ctyp< ($tv$,$tv'$) wire -> unit >> in
222
let method_type = Ast.TyPol (_loc, Ast.TyQuo(_loc,b), t) in
223
<:class_str_item< method $lid:"connect_"^a$ : $method_type$ = $lid:a$#connect >> in
224
List.map mill outputs
229
let ivl = fresh_var_names ~blacklist:port_names ~prefixes:inputs in
230
let ovl = fresh_var_names ~blacklist:(port_names@ivl) ~prefixes:outputs in
232
let va = <:ctyp< '$lid:a$ >> in
233
let vb = <:ctyp< '$lid:b$ >> in
234
<:ctyp< ($va$,$vb$) wire >>
236
let it = type_of_ctyp_list (List.map2 wire_type ivl inputs) in
237
let ot = type_of_ctyp_list (List.map2 wire_type outputs ovl) in
238
let qivl = List.map (fun x -> Ast.TyQuo(_loc,x)) ivl in
239
let qovl = List.map (fun x -> Ast.TyQuo(_loc,x)) ovl in
240
let pi = pattern_of_string_list inputs in
241
let po = pattern_of_string_list outputs in
242
let connect_actions = Ast.exSem_of_list (List.map connect_application port_names) in
243
match inputs, outputs with
244
| [] , [] -> assert false
246
let i_forall_vars = List.fold_left (fun x y -> Ast.TyApp (_loc,x,y)) (List.hd qivl) (List.tl qivl) in
247
let method_type = Ast.TyPol (_loc, i_forall_vars, <:ctyp< ($it$ -> unit)>>) in
248
[ <:class_str_item< method connect : $method_type$ = function $pi$ -> begin $connect_actions$ end >> ]
251
let o_forall_vars = List.fold_left (fun x y -> Ast.TyApp (_loc,x,y)) (List.hd qovl) (List.tl qovl) in
252
let method_type = Ast.TyPol (_loc, o_forall_vars, <:ctyp< ($ot$ -> unit)>>) in
253
[ <:class_str_item< method connect : $method_type$ = function $po$ -> begin $connect_actions$ end >> ]
256
let qvl = List.append qivl qovl in
257
let forall_vars = List.fold_left (fun x y -> Ast.TyApp (_loc,x,y)) (List.hd qvl) (List.tl qvl) in
258
let method_type = Ast.TyPol (_loc, forall_vars, <:ctyp< ($it$ -> $ot$ -> unit)>>) in
259
[ <:class_str_item< method connect : $method_type$ = function $pi$ -> function $po$ -> begin $connect_actions$ end >> ]
262
(* disconnect_? methods for all ports *)
264
let mill a = <:class_str_item< method $lid:"disconnect_"^a$ = $lid:a$#disconnect >> in
265
List.map mill port_names
268
(* disconnect method *)
270
let disconnect_actions = Ast.exSem_of_list (List.map disconnect_application port_names)
274
begin $disconnect_actions$ end
278
let get_wire_connections =
281
<:expr< ($str:a$, $lid:a$#connection#map (fun x -> x#readonly_wire#as_common)) >> in
286
<:expr< ($str:a$, $lid:a$#connection#map (fun x -> x#writeonly_wire#as_common)) >> in
287
List.map mill outputs
289
let il = expr_of_expr_list _loc connections_i in
290
let ol = expr_of_expr_list _loc connections_o in
291
[ <:class_str_item< method $lid:"input_wire_connections"$ = $il$ >> ;
292
<:class_str_item< method $lid:"output_wire_connections"$ = $ol$ >> ]
295
(* set_alone_? methods for output ports *)
298
<:class_str_item< method private $lid:"set_alone_"^a$ = $lid:a$#connection#extract#writeonly_wire#set_alone >> in
299
List.map mill outputs
302
(* stabilize method section *)
304
let unchanged_inputs = List.map (fun a -> fresh_var_name ~blacklist:port_names ~prefix:("unchanged_"^a)) inputs in
307
let mill (a,unchanged_a) =
308
let p = <:patt< ($lid:a$ , $lid:unchanged_a$) >> in
309
<:binding< $p$ = ($lid:a$#read_and_compare) >>
310
in Ast.biAnd_of_list (List.map mill (List.combine inputs unchanged_inputs))
314
let l = (List.map (fun unchanged_a -> <:expr< $lid:unchanged_a$ >>) unchanged_inputs) in
315
List.fold_right (fun e1 e2 -> <:expr< $e1$ && $e2$ >>) l <:expr< true >>
318
let output_bindings =
319
let inputs_as_lid_expressions = List.map (fun x -> <:expr< $lid:x$>>) inputs in
320
let firmware_application = apply _loc <:expr< self#firmware>> inputs_as_lid_expressions in
321
let output_pattern = pattern_of_string_list outputs in
322
<:binding< $output_pattern$ = $firmware_application$ >>
326
Ast.exSem_of_list (List.map set_alone_application outputs)
330
method stabilize : performed =
331
let $binding:input_bindings$ in
332
if ($unchanged_test$)
336
let $binding:output_bindings$ in
343
(* emit method section (for sources) *)
346
let arg = fresh_var_name ~blacklist:port_names ~prefix:"arg" in
348
let output_bindings =
349
let inputs_as_lid_expressions = List.map (fun x -> <:expr< $lid:x$>>) inputs in
350
let firmware_application = apply _loc <:expr< self#firmware $lid:arg$ >> inputs_as_lid_expressions in
351
let output_pattern = pattern_of_string_list outputs in
352
<:binding< $output_pattern$ = $firmware_application$ >>
355
let set_actions = Ast.exSem_of_list (List.map set_alone_application outputs)
359
method emit $lid:arg$ =
361
let $binding:output_bindings$ in
363
self#system#stabilize
364
in self#system#mutex_methods#with_mutex actions
369
(* Merging sections *)
370
let cst = Ast.crSem_of_list
382
get_wire_connections;
384
if is_source then emit else stabilize ;
385
user_complement_section ;
389
(* Class expression *)
393
fun ?(system : system = (Chip.get_or_initialize_current_system ())) () -> object (self) $cst$ end >> in
395
(* Class expression with optional parameters *)
396
let cop_list = List.map (fun i -> Ast.PaOlb (_loc, i, <:patt< >>)) port_names in
397
let cewop = List.fold_right (fun op ce -> <:class_expr< fun $op$ -> $ce$ >>) cop_list ce in
398
let cewop = <:class_expr< fun ?name ?(equality=(Pervasives.(=))) -> $cewop$ >> in
399
let cewop_with_user_parameters = lambda_class_expr _loc user_parameters cewop in
400
let internal_module_name = ("Chip_class_definition_"^class_name) in
401
let class_def = match is_virtual with
402
| false -> <:str_item< class [ $ctv$ ] $lid:class_name$ = $cewop_with_user_parameters$ >>
403
| true -> <:str_item< class virtual [ $ctv$ ] $lid:class_name$ = $cewop_with_user_parameters$ >>
407
module $uid:internal_module_name$ = struct
411
include $uid:internal_module_name$
421
let module M = Register.OCamlSyntaxExtension (Id) (Make) in ()
added
removed
chip/chip_parser_p4.ml
