Implémentation de la multiplication ; correction d'un bug dans netlist_gen ; ajout de la localisation des erreurs dans sched/.

6 files changed, 202 insertions, 71 deletions

diff --git a/cpu/alu.ml b/cpu/alu.ml
index f437bd3..9f83369 100644
--- a/cpu/alu.ml
+++ b/cpu/alu.ml
@@ -53,15 +53,117 @@ let nadder n a b =
     let a, b = nadder_with_carry n a b (const "0") in
     b ^. a
 
+let neg n a = nadder n (not a) (one n)
+
 let rec nsubber n a b =
-    zeroes n (* TODO *)
+  let r, c = nadder_with_carry n a (not b) (const "1") in
+  c ^. r
+
+
+
+
+(* Some operations on Redundant Binary Representation 
+   Each binary digit is encoded on 2 bits 
+
+   A n-digits number in RBR is written
+   [a_0, a'_0, a_1, a'_1, ..., a_(n-1), a'_(n-1)]
+
+*)
+
+(* [a] and [b] are encoded on 2n bits
+   [c_in] and [c_out] on 2 bits *)
+
+let rec rbr_nadder_with_carry n a b c_in =
+
+  if n = 0 then (zeroes 0), c_in else
+
+  let fa1s, fa1r = fulladder (a ** 1) (b ** 0) (b ** 1) in
+  let fa2s, fa2r = fulladder (c_in ** 1) (a ** 0) fa1s in
+
+  let rec_s, rec_c = 
+    rbr_nadder_with_carry (n - 1) 
+      (a % (2, 2*n - 1)) 
+      (b % (2, 2*n - 1)) 
+      (fa1r ++ fa2r)
+
+  in (c_in ** 0) ++ fa2s ++ rec_s, rec_c
+
+
+let rbr_nadder n a b = 
+  let s, c = rbr_nadder_with_carry n a b (zeroes 2) in
+  c ^. s
+
+
+let bin_of_rbr n a c = 
+
+  (* Split even and odd bits *)
+  let rec split_bits n a =
+    if n = 0 then (zeroes 0, zeroes 0) 
+    else
+      let even, odd = split_bits (n-1) (a % (2, 2*n - 1)) in
+      (a ** 0) ++ even, (a ** 1) ++ odd
+
+  in
+  let a_even, a_odd = split_bits n a in
+
+  nadder n a_even a_odd
+    
+    
+
+(* TODO : move to utils module *)
+let rec range a b = if a > b then [] else a :: (range (a+1) b)
+
+(* Sépare en deux listes de même taille une liste de taille paire *)
+let rec split_list = function
+  | [] -> [], []
+  | [_] -> assert false
+  | x::y::tl -> let a, b = split_list tl in x::a, y::b
+
+(* n must be a power of two *)
+(*
+let nmul n a b =
+
+  let summands = List.map (fun i ->  
+    mux (b ** i)
+      (zeroes (2*n))  
+      ((zeroes i) ++ a ++ (zeroes (n - i)))
+      
+  ) (range 0 (n-1)) in
+
+  
+  let rec sum_list = function
+    | [x] -> x
+    | l -> 
+        let s1, s2 = split_list l in 
+        nadder (2*n) (sum_list s1) (sum_list s2)
+
+  in let r = List.fold_left (nadder (2*n)) (List.hd summands) (List.tl summands) in
+
+
+  (*in 
+  let r = sum_list summands in*)
+  (r % (0, n-1)), (r % (n, 2*n - 1))
+  *)
+
+let nmul n a b =
+  let nn = 2*n in
+  let result = ref (zeroes (nn)) in
+  for i = 0 to n-1 do
+    result := mux (b ** i) !result (nadder nn !result ((zeroes i) ++ a ++ (zeroes (n-i))))
+  done;
+  let r = !result in
+  r % (0, n-1), r % (n, nn-1)
+    
+
+
 
-let rec nmul n a b =
-    zeroes n, zeroes n (* TODO : retuns lo and hi part of 32-bit answer *)
 
 let rec ndiv n a b =
     zeroes n, zeroes n (* TODO : returns quotient and remainder *)
 
+
+
+
 let rec nmulu n a b =
     zeroes n, zeroes n (* TODO : same as nmul but unsigned *)
 
diff --git a/cpu/cpu.ml b/cpu/cpu.ml
index 3f9dd74..c5643ec 100644
--- a/cpu/cpu.ml
+++ b/cpu/cpu.ml
@@ -313,5 +313,5 @@ let p =
             "ser_in_busy", 1, ser_in_busy;
         ]
 
-let () = Netlist_gen.print stdout p
+let () = Netlist_printer.print_program stdout p
 
diff --git a/cpu/netlist_gen.ml b/cpu/netlist_gen.ml
index 016c595..956de91 100644
--- a/cpu/netlist_gen.ml
+++ b/cpu/netlist_gen.ml
@@ -59,7 +59,12 @@ let ( ++ ) v1 v2 =
             let x1, p = v1 p in
             let x2, p = v2 p in
             let sz1, sz2 = get_size p x1, get_size p x2 in
-            (Avar i), add p i (Econcat (x1, x2)) (sz1 + sz2)
+            if sz1 = 0 then
+              (x2), p
+            else if sz2 = 0 then
+              (x1), p
+            else
+              (Avar i), add p i (Econcat (x1, x2)) (sz1 + sz2)
     
 let ( ^| ) v1 v2 =
     let i = id "" in
@@ -198,66 +203,3 @@ let program entries outputs =
         p_outputs = List.rev outputs }
 
 
-(* Netlist printer *)
-
-let init_string n f =
-    let s = String.make n 'a' in
-    for i = 0 to n - 1 do
-        s.[i] <- f i
-    done;
-    s
-
-(* value to string *)
-let vts bits =
-    init_string (Array.length bits) (fun i ->
-        if bits.(i) then '1' else '0')
-
-(* argument to string *)
-let ats = function
-    | Avar id -> id
-    | Aconst n -> vts n
-    
-let s_op = function
-    | Or -> "OR"
-    | Xor -> "XOR"
-    | And -> "AND"
-    | Nand -> "NAND"
-
-let print oc p =
-    let print_eq oc (s,e) = 
-        let s_e =
-            match e with
-            | Earg a -> ats a
-            | Ereg s -> "REG " ^ s
-            | Enot a -> "NOT " ^ (ats a)
-            | Ebinop (b,a1,a2) -> (s_op b) ^ " " ^ (ats a1) ^ " " ^ (ats a2)
-            | Emux (a1,a2,a3) ->
-                "MUX " ^ (ats a1) ^ " " ^ (ats a2) ^ " " ^ (ats a3)
-            | Erom (n1,n2,a3) ->
-                "ROM " ^ (string_of_int n1) ^ " " ^ (string_of_int n2) ^
-                    " " ^ (ats a3)
-            | Eram (n1,n2,a3,a4,a5,a6) ->
-                "RAM " ^ (string_of_int n1) ^ " " ^ (string_of_int n2) ^
-                    " " ^ (ats a3) ^ " " ^ (ats a4) ^ " " ^ (ats a5) ^
-                    " " ^ (ats a6)
-            | Econcat (a1,a2) -> "CONCAT " ^ (ats a1) ^ " " ^ (ats a2)
-            | Eslice (n1,n2,a3) -> "SLICE " ^ (string_of_int n1) ^ " " ^
-                (string_of_int n2) ^ " " ^ (ats a3)
-            | Eselect (n,a) -> "SELECT " ^ (string_of_int n) ^ " " ^ (ats a) in
-        Printf.fprintf oc "%s = %s\n" s s_e in
-    Printf.fprintf oc "INPUT ";
-    if p.p_inputs <> [] then
-        (Printf.fprintf oc "%s" (List.hd p.p_inputs); List.iter 
-            (Printf.fprintf oc ", %s") (List.tl p.p_inputs));
-    Printf.fprintf oc "\nOUTPUT ";
-    if p.p_outputs <> [] then
-        (Printf.fprintf oc "%s" (List.hd p.p_outputs); List.iter 
-            (Printf.fprintf oc ", %s") (List.tl p.p_outputs));
-    Printf.fprintf oc "\nVAR ";
-    let stts s t = if t = 1 then s else s ^ " : " ^ (string_of_int t) in
-    Pervasives.ignore (Env.fold (fun s t b -> 
-        if b then Printf.fprintf oc "%s" (stts s t)
-        else Printf.fprintf oc ", %s" (stts s t);
-        false) p.p_vars true);
-    Printf.fprintf oc "\nIN\n";
-    List.iter (print_eq oc) p.p_eqs
diff --git a/cpu/netlist_gen.mli b/cpu/netlist_gen.mli
index 67d4774..24cd6f1 100644
--- a/cpu/netlist_gen.mli
+++ b/cpu/netlist_gen.mli
@@ -1,7 +1,5 @@
 type t
 
-val print : out_channel -> Netlist_ast.program -> unit
-
 val get : Netlist_ast.ident -> t
 val loop : int -> (t * (t -> t))
 
diff --git a/cpu/netlist_printer.ml b/cpu/netlist_printer.ml
new file mode 100644
index 0000000..2c80d70
--- /dev/null
+++ b/cpu/netlist_printer.ml
@@ -0,0 +1,82 @@
+open Netlist_ast
+open Format
+
+let rec print_env print lp sep rp ff env =
+  let first = ref true in
+  fprintf ff "%s" lp;
+  Env.iter
+    (fun x ty ->
+      if !first then
+        (first := false; fprintf ff "%a" print (x, ty))
+      else
+        fprintf ff "%s%a" sep print (x, ty)) env;
+  fprintf ff "%s" rp
+
+let rec print_list print lp sep rp ff = function
+  | [] -> ()
+  | x :: l ->
+      fprintf ff "%s%a" lp print x;
+      List.iter (fprintf ff "%s %a" sep print) l;
+      fprintf ff "%s" rp
+
+let print_ty ff n = 
+  fprintf ff " : %d" n
+
+let print_bool ff b =
+  if b then
+    fprintf ff "1"
+  else
+    fprintf ff "0"
+
+let print_value ff a =
+  Array.iter (print_bool ff) a
+
+let print_arg ff arg = match arg with
+  | Aconst v -> print_value ff v
+  | Avar id -> fprintf ff "%s" id
+
+let print_op ff op = match op with
+  | And -> fprintf ff "AND"
+  | Nand -> fprintf ff "NAND"
+  | Or -> fprintf ff "OR"
+  | Xor -> fprintf ff "XOR"
+
+let print_exp ff e = match e with
+  | Earg a -> print_arg ff a
+  | Ereg x -> fprintf ff "REG %s" x
+  | Enot x -> fprintf ff "NOT %a" print_arg x
+  | Ebinop(op, x, y) -> fprintf ff  "%a %a %a" print_op op  print_arg x  print_arg y
+  | Emux (c, x, y) -> fprintf ff "MUX %a %a %a " print_arg c  print_arg x  print_arg y
+  | Erom (addr, word, ra) -> fprintf ff "ROM %d %d %a" addr word  print_arg ra
+  | Eram (addr, word, ra, we, wa, data) ->
+      fprintf ff "RAM %d %d %a %a %a %a" addr word
+        print_arg ra  print_arg we
+        print_arg wa  print_arg data
+  | Eselect (idx, x) -> fprintf ff "SELECT %d %a" idx print_arg x
+  | Econcat (x, y) ->  fprintf ff  "CONCAT %a %a" print_arg x  print_arg y
+  | Eslice (min, max, x) -> fprintf ff "SLICE %d %d %a" min max print_arg x
+
+let print_eq ff (x, e) =
+  fprintf ff "%s = %a@." x print_exp e
+
+let print_var ff (x, ty) =
+  fprintf ff "@[%s%a@]" x print_ty ty
+
+let print_vars ff env =
+  fprintf ff "@[<v 2>VAR@,%a@]@.IN@,"
+    (print_env print_var "" ", " "") env
+
+let print_idents ff ids =
+  let print_ident ff s = fprintf ff "%s" s in
+  print_list print_ident """,""" ff ids
+
+let print_program oc p =
+  let ff = formatter_of_out_channel oc in
+  fprintf ff "INPUT %a@." print_idents p.p_inputs;
+  fprintf ff "OUTPUT %a@." print_idents p.p_outputs;
+  print_vars ff p.p_vars;
+  List.iter (print_eq ff) p.p_eqs;
+  (* flush *)
+  fprintf ff "@."
+
+
diff --git a/sched/netlist_lexer.mll b/sched/netlist_lexer.mll
index 60cb223..ec27367 100644
--- a/sched/netlist_lexer.mll
+++ b/sched/netlist_lexer.mll
@@ -1,5 +1,6 @@
 {
 open Netlist_parser
+open Lexing
 exception Eof
 
 let keyword_list =
@@ -22,10 +23,16 @@ let keyword_list =
   "XOR", XOR;
 ]
 
+let newline lexbuf =
+  let pos = lexbuf.lex_curr_p in
+  lexbuf.lex_curr_p <- 
+    { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum }
+
 }
 
 rule token = parse
-    [' ' '\t' '\n']     { token lexbuf }     (* skip blanks *)
+  | '\n'          { newline lexbuf ; token lexbuf }
+  |  [' ' '\t']     { token lexbuf }     (* skip blanks *)
   | "="            { EQUAL }
   | ":"            { COLON }
   | ","            { COMMA }