Skip to content

GitLab

S
stage-L3-2016
Commit 278f3697 authored by Aliaume Lopez's avatar Aliaume Lopez
Browse files
Options

Rewriting huge progress

parent 7e2f733a
Hide whitespace changes
Inline Side-by-side
Showing with 1683 additions and 160 deletions
circuits.ml
View file @ 278f3697
......@@ -2,24 +2,40 @@
*
* circuits.ml
*
* Dan Ghica
* Aliaume Lopez
*
* Entry point of the program
* generates dot output,
* handles graph reduction,
* embedded DSL, and all.
* TODO
*
* « aliaume hook » is the
* hook from all the rest of
* the librairies into this
* file to interface the new
* language and definition to
* the new model
* 1) rules
* a) Dangle : propagating disconnect nodes
* b) Garbage collect nodes
* c) fork constant
* d) gate reduce (end the work)
*
* 3) compiling from dags
*
* 4) waveforms ?
*
*)
open Dot;;
let rec zip_with_3 f a b c = match (a,b,c) with
| [],[],[] -> []
| a1::a2,b1::b2,c1::c2 ->
(f a1 b1 c1) :: zip_with_3 f a2 b2 c2;;
let rec zip_with_4 f a b c d = match (a,b,c,d) with
| [],[],[],[] -> []
| a1::a2,b1::b2,c1::c2,d1::d2 ->
(f a1 b1 c1 d1) :: zip_with_4 f a2 b2 c2 d2;;
let rec zip_with f a b = match (a,b) with
| [],[] -> []
| a1::a2,b1::b2 ->
(f a1 b1) :: zip_with f a2 b2;;
module ComparableInts =
struct
type t = int
......@@ -104,8 +120,6 @@ type label =
*
*)
type ptg = {
maxid : int; (* the maximum id inside the graph *)
(* naturally have a notion of order *)
iports : nid list;
oports : nid list;
......@@ -134,26 +148,6 @@ type ptg = {
}
(*** PRETTY PRINTING ***)
let string_of_gate = function
| Fork -> "F"
| Join -> "J"
| Nmos -> "N"
| Pmos -> "P"
| Box s -> "B " ^ s
| Wait -> "W"
| Mux -> "M"
| Disconnect -> "D";;
let string_of_value = function
| High -> "H"
| Low -> "L"
| Top -> "T"
| Bottom -> "Z";;
let string_of_label = function
| Value v -> string_of_value v
| Gate g -> string_of_gate g;;
(**
......@@ -195,31 +189,6 @@ let pp_ptg ptg = ptg |> string_of_ptg |> print_string;;
(**** DOT CONVERSION ****)
let example_ptg =
{
maxid = 6;
iports = [1;2];
oports = [3];
traced = [];
delays = [];
nodes = [(0,4,0);
(0,5,9);
(2,6,1)];
labels = id_empty |> id_add 4 (Gate Fork)
|> id_add 5 (Gate Join)
|> id_add 6 (Gate (Box "Test"));
edges = [ (1,None,4,None);
(2,None,5,None);
(4,None,6,Some 1);
(5,None,6,Some 2);
(6,Some 1, 3, None) ]
};;
let dot_of_ptg ptg =
let init_rank = rank_group "min" ptg.iports in
......@@ -284,21 +253,48 @@ let newid () =
let newids n = Utils.range n |> List.map (fun _ -> newid ());;
(** Duplique un ptg **)
(** TEMPORARY FUNCTIONS **)
let make_arrow x y =
(x,None,y,None);;
(** Working on edges **)
let is_from ~node:n ~edge:e =
match e with
| (a,_,_,_) -> a = n;;
let is_to ~node:n ~edge:e =
match e with
| (_,_,a,_) -> a = n;;
let is_from_l ~nodes:l ~edge:e =
List.exists (fun x -> is_from x e) l;;
let is_to_l ~nodes:l ~edge:e =
List.exists (fun x -> is_to x e) l;;
let set_from ~node:n ~edge:(x,y,z,t) = (n,y,z,t);;
let set_to ~node:n ~edge:(x,y,z,t) = (x,y,n,t);;
(**
* Create a copy of the ptg with
* a disjoint set of nodes
* along with the translation function
*)
let replicate ptg =
let translate x = x + ptg.maxid in
let m = !counter in
let translate x = x + m + 1 in
let update_label m (oldid,lbl) =
id_add (translate oldid) lbl m
in
counter := translate !counter;
counter := translate m;
(translate, {
maxid = translate ptg.maxid;
iports = List.map translate ptg.iports;
oports = List.map translate ptg.iports;
oports = List.map translate ptg.oports;
traced = List.map translate ptg.traced;
delays = List.map translate ptg.delays;
......@@ -315,70 +311,90 @@ let replicate ptg =
});;
(** Working on edges **)
let is_from ~node:n ~edge:e =
match e with
| (a,_,_,_) -> a = n;;
let pre_nodes ~node:n t =
t.edges |> List.filter (fun e -> is_to ~node:n ~edge:e);;
let is_to ~node:n ~edge:e =
match e with
| (_,_,a,_) -> a = n;;
let post_nodes ~node:n t =
t.edges |> List.filter (fun e -> is_from ~node:n ~edge:e);;
let is_from_l ~nodes:l ~edge:e =
List.exists (fun x -> is_from x e) l;;
let is_to_l ~nodes:l ~edge:e =
List.exists (fun x -> is_to x e) l;;
let remove_node ~node:n t =
let node_rem (_,x,_) = not (x = n) in
let simple_rem x = not (x = n) in
let edge_rem e =
(is_from ~node:n ~edge:e) || (is_to ~node:n ~edge:e)
in
let set_from ~node:n ~edge:(x,y,z,t) = (n,y,z,t);;
let set_to ~node:n ~edge:(x,y,z,t) = (x,y,n,t);;
{
edges = List.filter edge_rem t.edges ;
nodes = List.filter node_rem t.nodes ;
iports = List.filter simple_rem t.iports ;
oports = List.filter simple_rem t.oports ;
traced = List.filter simple_rem t.traced ;
delays = List.filter simple_rem t.delays ;
(** Split the trace of a pTG
labels = id_remove n t.labels
};;
(**
*
**)
let split_trace ptg =
let trids = newids (List.length ptg.traced) in
let corres = List.combine ptg.traced trids in
let edge_mod (oldt,newt) e =
if is_from ~node:oldt ~edge:e then
set_from ~node:newt ~edge:e
else
e
* Remove a _main_ node
*
* Create new Disconnect for the pre
* Create new Bottoms for the post
*
* --> this way the circuit is always
* correct : no strange modifications
*
* *)
let remove_node_safe ~node:n t =
let bottoms = ref [] in
let discard = ref [] in
let new_bottom () =
let x = newid () in
bottoms := x :: !bottoms;
x
in
let update_edges l p =
l |> List.map (edge_mod p)
let new_discard () =
let x = newid () in
discard := x :: !discard;
x
in
let traced_to_main x = (1,x,1) in
(corres, {
ptg with
maxid = !counter;
traced = [];
nodes = List.map traced_to_main (ptg.traced @ trids) @ ptg.nodes;
edges = List.fold_left update_edges ptg.edges corres;
});;
(** Remove a _main_ node *)
let remove_node ~node:n t =
let edge_rem e =
not (is_from ~node:n ~edge:e || is_to ~node:n ~edge:e)
let edge_mod e =
if is_from ~node:n ~edge:e then
let (_,_,x,i) = e in
(new_bottom (), None, x, i)
else if is_to ~node:n ~edge:e then
let (x,i,_,_) = e in
(x, i, new_discard (), None)
else
e
in
let node_rem (_,x,_) = not (x = n) in
let simple_rem x = not (x = n) in
let add_bottoms l =
List.fold_left (fun a b -> id_add b (Value Bottom) a) l !bottoms
in
let add_discard l =
List.fold_left (fun a b -> id_add b (Gate Disconnect) a) l !discard
in
{ t with
edges = List.filter edge_rem t.edges ;
nodes = List.filter node_rem t.nodes ;
edges = List.map edge_mod t.edges ;
nodes = List.map (fun x -> (0,x,0)) !bottoms
@ List.map (fun x -> (0,x,0)) !discard
@ List.filter node_rem t.nodes ;
traced = List.filter simple_rem t.traced ;
delays = List.filter simple_rem t.delays ;
oports = List.filter simple_rem t.oports ;
iports = List.filter simple_rem t.iports ;
labels = t.labels |> id_remove n;
labels = t.labels |> id_remove n |> add_bottoms |> add_discard
};;
let pre_nodes ~node:n t =
t.edges |> List.filter (fun e -> is_to ~node:n ~edge:e);;
let post_nodes ~node:n t =
t.edges |> List.filter (fun e -> is_from ~node:n ~edge:e);;
let relabel_node ~node:n ~label:l t =
{
......@@ -388,6 +404,9 @@ let relabel_node ~node:n ~label:l t =
|> id_add n l
};;
let relabel_l ~nodes:ns ~label:l t =
List.fold_left (fun b a -> relabel_node ~node:a ~label:l b) t ns;;
(** adding an edge
*
* Does not include sanity checks
......@@ -399,6 +418,17 @@ let add_edge ~edge:e t =
edges = e :: t.edges
};;
let add_node ~node:e t =
{ t with
nodes = (0,e,0) :: t.nodes
};;
let add_nodes ~nodes:l t =
List.fold_left
(fun a b -> add_node ~node:b a)
t
l;;
(**
* Try moving a node to main,
* does nothing if main already exists
......@@ -408,7 +438,7 @@ let move_to_main ~node:n t =
let simple_rem x = not (x = n) in
if try_find = [] then
{ t with
nodes = (1,n,1) :: t.nodes;
nodes = (0,n,0) :: t.nodes;
traced = List.filter simple_rem t.traced ;
delays = List.filter simple_rem t.delays ;
oports = List.filter simple_rem t.oports ;
......@@ -417,6 +447,75 @@ let move_to_main ~node:n t =
else
t;;
let flatten_ptg g =
let others = g.iports @ g.oports @ g.traced @ g.delays in
List.fold_left (fun a b -> move_to_main ~node:b a)
g others;;
let merger_v k x y =
match x with
| Some v -> Some v
| None -> y;;
(**
* The two graphs have
* distinct node names
*)
let ptg_merge g1 g2 =
{
nodes = (flatten_ptg g1).nodes @ (flatten_ptg g2).nodes ;
delays = [];
traced = [];
iports = [];
oports = [];
labels = id_merge merger_v g1.labels g2.labels;
edges = g1.edges @ g2.edges;
};;
(** Dispatch nodes *)
let dispatch_with ~f ~from1 ~from2 ~fst ~snd g =
let make_edge a b c d =
if f c d g then
[
(a,None,c,None);
(b,None,d,None)
]
else
[
(b,None,c,None);
(a,None,d,None)
]
in
{ g with
edges = List.concat (zip_with_4 make_edge from1 from2 fst snd) @ g.edges
};;
let set_inputs ~nodes:l ptg =
{
ptg with
iports = l
};;
let set_outputs ~nodes:l ptg =
{
ptg with
oports = l
};;
let set_delays ~nodes:l ptg =
{
ptg with
delays = l
};;
let set_trace ~nodes:l ptg =
{
ptg with
traced = l
};;
(**
* Checks if a node is in the main
* graph (not special set)
......@@ -431,6 +530,97 @@ let delete_label ~node:n t =
labels = t.labels |> id_remove n
};;
let delete_label_l ~nodes:n t =
List.fold_left
(fun a b -> delete_label ~node:b a)
t
n;;
let connect ~from:i ~towards:j ptg =
{ ptg with
edges = zip_with make_arrow i j @ ptg.edges
};;
let mk_join ~towards ~fst ~snd ptg =
let new_joins = newids (List.length towards) in
ptg |> add_nodes ~nodes:new_joins
|> connect ~from:fst ~towards:new_joins
|> connect ~from:snd ~towards:new_joins
|> connect ~from:new_joins ~towards:towards
|> relabel_l ~nodes:new_joins ~label:(Gate Join);;
let mk_fork ~from ~fst ~snd ptg =
let new_forks = newids (List.length from) in
ptg |> add_nodes ~nodes:new_forks
|> connect ~from:new_forks ~towards:fst
|> connect ~from:new_forks ~towards:snd
|> connect ~from:from ~towards:new_forks
|> relabel_l ~nodes:new_forks ~label:(Gate Fork);;
let rec fork_into ~node:n ~nodes:l ptg =
match l with
| [] -> ptg
| [t] ->
ptg |> add_edge ~edge:(n,None,t,None)
| t :: q ->
let fork_node = newid () in
ptg |> fork_into ~node:fork_node ~nodes:q
|> add_node ~node:fork_node
|> relabel_node ~node:fork_node ~label:(Gate Fork)
|> add_edge ~edge:(fork_node,None,t,None)
|> add_edge ~edge:(n,None,fork_node,None);;
let rec join_into ~node:n ~nodes:l ptg =
match l with
| [] -> ptg
| [t] ->
ptg |> add_edge ~edge:(t,None,n,None)
| t :: q ->
let join_node = newid () in
ptg |> join_into ~node:join_node ~nodes:q
|> add_node ~node:join_node
|> relabel_node ~node:join_node ~label:(Gate Join)
|> add_edge ~edge:(t,None,join_node,None)
|> add_edge ~edge:(join_node,None,n,None);;
(** Split the trace of a pTG
*
**)
let split_trace ptg =
let trids = newids (List.length ptg.traced) in
let corres = List.combine ptg.traced trids in
let edge_mod (oldt,newt) e =
if is_from ~node:oldt ~edge:e then
set_from ~node:newt ~edge:e
else
e
in
let update_edges l p =
l |> List.map (edge_mod p)
in
let traced_to_main_left x = (0,x,0) in
let traced_to_main_right x = (0,x,0) in
(trids, ptg.traced, {
ptg with
traced = [];
nodes = List.map traced_to_main_left ptg.traced
@ List.map traced_to_main_right trids
@ ptg.nodes;
edges = List.fold_left update_edges ptg.edges corres;
});;
(***
* The original PTG does not have any trace
*)
let connect_trace ~from:i ~towards:j ptg =
let new_trace = newids (List.length i) in
ptg |> connect ~from:i ~towards:new_trace
|> connect ~from:new_trace ~towards:j
|> set_trace ~nodes:new_trace;;
(**
* Change a node's signature
* and the edges according to
......@@ -470,6 +660,7 @@ let signature_node ~node:n ~ins:i ~outs:j t =
(**
* pass a constant node through
* a simple node
* the node can be a traced one
*)
let propagate_constant ~node:n t =
match id_find n t.labels with
......@@ -483,7 +674,7 @@ let propagate_constant ~node:n t =
| None -> false
| Some _ -> true
in
(*
(*
* replace the node if and only if there is
* only us on the node, and it is a non-labeled
* node
......@@ -507,14 +698,17 @@ let propagate_constant ~node:n t =
let simplify_identity ~node:n t =
match id_find n t.labels with
| None ->
begin (* an unlabeled node is ALWAYS an identity *)
let [x,i,_,_] = pre_nodes ~node:n t in
let [_,_,y,j] = post_nodes ~node:n t in
if is_main_node ~node:x t && is_main_node ~node:y t then
t |> remove_node ~node:n
|> add_edge ~edge:(x,i,y,j)
else
t
begin
try
let [x,i,_,_] = pre_nodes ~node:n t in
let [_,_,y,j] = post_nodes ~node:n t in
if is_main_node ~node:x t && is_main_node ~node:y t then
t |> remove_node ~node:n
|> add_edge ~edge:(x,i,y,j)
else
t
with
Match_failure _ -> t
end
| Some _ -> t;;
......@@ -553,14 +747,14 @@ let reduce_mux ~node:mux t =
in
match v1 with
| Top ->
first |> relabel_node ~node:p2 ~label:(Gate Disconnect)
|> relabel_node ~node:p3 ~label:(Gate Disconnect)
|> relabel_node ~node:mux ~label:(Value Top)
first |> relabel_node ~node:p2 ~label:(Gate Disconnect)
|> relabel_node ~node:p3 ~label:(Gate Disconnect)
|> relabel_node ~node:mux ~label:(Value Top)
|> signature_node ~node:mux ~ins:0 ~outs:0
| Bottom ->
first |> relabel_node ~node:p2 ~label:(Gate Disconnect)
|> relabel_node ~node:p3 ~label:(Gate Disconnect)
|> relabel_node ~node:mux ~label:(Value Bottom)
first |> relabel_node ~node:p2 ~label:(Gate Disconnect)
|> relabel_node ~node:p3 ~label:(Gate Disconnect)
|> relabel_node ~node:mux ~label:(Value Bottom)
|> signature_node ~node:mux ~ins:0 ~outs:0
| Low ->
first
......@@ -575,55 +769,283 @@ let reduce_mux ~node:mux t =
| _ -> t;;
let join_values a b = match a,b with
| Bottom,_ -> b
| _,Bottom -> a
| High,Low -> Top
| Low,High -> Top
| Top,_ -> Top
| _,Top -> Top
| _ -> a;; (* otherwise a = b = join a b *)
(* TODO nmos & pmos table *)
let nmos_values a b = a;;
let pmos_values a b = a;;
let function_of_gate = function
| Join -> join_values
| Nmos -> nmos_values
| Pmos -> pmos_values ;;
let reduce_gate ~node:n ptg =
match id_find n ptg.labels with
| Some (Gate Mux) -> reduce_mux ~node:n ptg
| Some (Gate g) when List.mem g [Join;Nmos;Pmos] ->
begin
let inputs = pre_nodes ~node:n ptg in
let trait_inpt (x,j,_,i) = (j,x,i, id_find x ptg.labels) in
let compare_input (_,_,i,_) (_,_,j,_) = compare i j in
let real_inputs = inputs
|> List.map trait_inpt
|> List.sort compare_input
|> List.map (fun (j,x,_,y) -> (j,x,y))
in
match real_inputs with
| [(_ ,p1,Some (Value v1));
(k2,p2,Some (Value v2)) ] ->
begin
ptg |> remove_node ~node:p1
|> remove_node ~node:p2
|> signature_node ~node:n ~ins:0 ~outs:0 (** set regular node **)
|> relabel_node ~node:n ~label:(Value (function_of_gate g v1 v2))
end
(* TODO pmos AND nmos short circuit *)
(* TODO join short circuit too *)
| _ -> ptg
let reduce_times ptg1 =
let ptg2 = replicate ptg1 in
let new_inputs = ... in
dispatch f new_inputs ptg1.inputs ptg2.inputs
end
| _ -> ptg;;
mk_join new_outputs ptg1.outputs ptg2.outputs
relabel ptg1.outputs DELAY
let yank_constant ~node:n ptg =
match id_find n ptg.labels with
| Some (Value v) ->
begin
match post_nodes ~node:n ptg with
| [(_,_,t,_)] ->
if List.mem t ptg.traced then