Fix ordering of generated anonymous types for each cdef

2 files changed, 98 insertions, 27 deletions

diff --git a/src/bytecode_util.ml b/src/bytecode_util.ml
index ed042c51..188d71cc 100644
--- a/src/bytecode_util.ml
+++ b/src/bytecode_util.ml
@@ -193,6 +193,15 @@ and string_of_ctyp = function
   | CT_ref ctyp -> "ref(" ^ string_of_ctyp ctyp ^ ")"
   | CT_poly -> "*"
 
+let rec map_ctyp f = function
+  | (CT_int | CT_int64 | CT_bits _ | CT_bits64 _ | CT_bit | CT_unit | CT_bool | CT_real | CT_string | CT_poly | CT_enum _) as ctyp -> f ctyp
+  | CT_tup ctyps -> f (CT_tup (List.map (map_ctyp f) ctyps))
+  | CT_ref ctyp -> f (CT_ref (map_ctyp f ctyp))
+  | CT_vector (direction, ctyp) -> f (CT_vector (direction, map_ctyp f ctyp))
+  | CT_list ctyp -> f (CT_list (map_ctyp f ctyp))
+  | CT_struct (id, ctors) -> f (CT_struct (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors))
+  | CT_variant (id, ctors) -> f (CT_variant (id, List.map (fun (id, ctyp) -> id, map_ctyp f ctyp) ctors))
+
 let rec ctyp_equal ctyp1 ctyp2 =
   match ctyp1, ctyp2 with
   | CT_int, CT_int -> true
@@ -283,7 +292,7 @@ let rec pp_clexp = function
   | CL_field (id, field, ctyp) -> pp_id id ^^ string "." ^^ string field ^^ string " : " ^^ pp_ctyp ctyp
   | CL_addr (id, ctyp) -> string "*" ^^ pp_id id ^^ string " : " ^^ pp_ctyp ctyp
   | CL_addr_field (id, field, ctyp) -> pp_id id ^^ string "->" ^^ string field ^^ string " : " ^^ pp_ctyp ctyp
-  | CL_current_exception _ -> string "current_exception"
+  | CL_current_exception ctyp -> string "current_exception : " ^^ pp_ctyp ctyp
   | CL_have_exception -> string "have_exception"
 
 let rec pp_instr ?short:(short=false) (I_aux (instr, aux)) =
@@ -552,6 +561,36 @@ let make_dot id graph =
   Util.opt_colors := true;
   close_out out_chan
 
+let rec map_clexp_ctyp f = function
+  | CL_id (id, ctyp) -> CL_id (id, f ctyp)
+  | CL_field (id, field, ctyp) -> CL_field (id, field, f ctyp)
+  | CL_addr (id, ctyp) -> CL_addr (id, f ctyp)
+  | CL_addr_field (id, field, ctyp) -> CL_addr_field (id, field, f ctyp)
+  | CL_current_exception ctyp -> CL_current_exception (f ctyp)
+  | CL_have_exception -> CL_have_exception
+
+let rec map_instr_ctyp f (I_aux (instr, aux)) =
+  let instr = match instr with
+    | I_decl (ctyp, id) -> I_decl (f ctyp, id)
+    | I_init (ctyp1, id, (frag, ctyp2)) -> I_init (f ctyp1, id, (frag, f ctyp2))
+    | I_if ((frag, ctyp1), then_instrs, else_instrs, ctyp2) ->
+       I_if ((frag, f ctyp1), List.map (map_instr_ctyp f) then_instrs, List.map (map_instr_ctyp f) else_instrs, f ctyp2)
+    | I_jump ((frag, ctyp), label) -> I_jump ((frag, f ctyp), label)
+    | I_funcall (clexp, extern, id, cvals) ->
+       I_funcall (map_clexp_ctyp f clexp, extern, id, List.map (fun (frag, ctyp) -> frag, f ctyp) cvals)
+    | I_copy (clexp, (frag, ctyp)) -> I_copy (map_clexp_ctyp f clexp, (frag, f ctyp))
+    | I_clear (ctyp, id) -> I_clear (f ctyp, id)
+    | I_return (frag, ctyp) -> I_return (frag, f ctyp)
+    | I_block instrs -> I_block (List.map (map_instr_ctyp f) instrs)
+    | I_try_block instrs -> I_try_block (List.map (map_instr_ctyp f) instrs)
+    | I_throw (frag, ctyp) -> I_throw (frag, f ctyp)
+    | I_undefined ctyp -> I_undefined (f ctyp)
+    | I_reset (ctyp, id) -> I_reset (f ctyp, id)
+    | I_reinit (ctyp1, id, (frag, ctyp2)) -> I_reinit (f ctyp1, id, (frag, f ctyp2))
+    | (I_comment _ | I_raw _ | I_label _ | I_goto _ | I_match_failure) as instr -> instr
+  in
+  I_aux (instr, aux)
+
 (** Map over each instruction within an instruction, bottom-up *)
 let rec map_instr f (I_aux (instr, aux)) =
   let instr = match instr with
@@ -577,6 +616,16 @@ let cdef_map_instr f = function
   | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, ctyps, ctyp)
   | CDEF_type tdef -> CDEF_type tdef
 
+(** Map over each ctyp in a cdef using map_instr_ctyp *)
+let cdef_map_ctyp f = function
+  | CDEF_reg_dec (id, ctyp, instrs) -> CDEF_reg_dec (id, f ctyp, List.map (map_instr_ctyp f) instrs)
+  | CDEF_let (n, bindings, instrs) -> CDEF_let (n, bindings, List.map (map_instr_ctyp f) instrs)
+  | CDEF_fundef (id, heap_return, args, instrs) -> CDEF_fundef (id, heap_return, args, List.map (map_instr_ctyp f) instrs)
+  | CDEF_startup (id, instrs) -> CDEF_startup (id, List.map (map_instr_ctyp f) instrs)
+  | CDEF_finish (id, instrs) -> CDEF_finish (id, List.map (map_instr_ctyp f) instrs)
+  | CDEF_spec (id, ctyps, ctyp) -> CDEF_spec (id, List.map f ctyps, f ctyp)
+  | CDEF_type tdef -> CDEF_type tdef (* FIXME *)
+
 (* Map over all sequences of instructions contained within an instruction *)
 let rec map_instrs f (I_aux (instr, aux)) =
   let instr = match instr with
diff --git a/src/c_backend.ml b/src/c_backend.ml
index 70c50060..19916c6a 100644
--- a/src/c_backend.ml
+++ b/src/c_backend.ml
@@ -1790,6 +1790,11 @@ let rec specialize_variants ctx =
 
   let unifications = ref (Bindings.empty) in
 
+  let fix_variant_ctyp var_id new_ctors = function
+    | CT_variant (id, ctors) when Id.compare id var_id = 0 -> CT_variant (id, new_ctors)
+    | ctyp -> ctyp
+  in
+
   let specialize_constructor ctx ctor_id ctyp =
     let ctyps = match ctyp with
     | CT_tup ctyps -> ctyps
@@ -1845,8 +1850,7 @@ let rec specialize_variants ctx =
   function
   | (CDEF_type (CTD_variant (var_id, ctors)) as cdef) :: cdefs ->
      let polymorphic_ctors = List.filter (fun (_, ctyp) -> is_polymorphic ctyp) ctors in
-     List.iter (fun (id, ctyp) -> prerr_endline (Printf.sprintf "%s : %s" (string_of_id id) (string_of_ctyp ctyp))) polymorphic_ctors;
-     prerr_endline "=== CONSTRUCTORS ===";
+     (* List.iter (fun (id, ctyp) -> prerr_endline (Printf.sprintf "%s : %s" (string_of_id id) (string_of_ctyp ctyp))) polymorphic_ctors; *)
 
      let cdefs =
        List.fold_left (fun cdefs (ctor_id, ctyp) -> List.map (cdef_map_instr (specialize_constructor ctx ctor_id ctyp)) cdefs)
@@ -1855,13 +1859,16 @@ let rec specialize_variants ctx =
      in
 
      let monomorphic_ctors = List.filter (fun (_, ctyp) -> not (is_polymorphic ctyp)) ctors in
+     let specialized_ctors = Bindings.bindings !unifications in
+     let new_ctors = monomorphic_ctors @ specialized_ctors in
 
      let ctx = { ctx with variants = Bindings.add var_id
                                                   (List.fold_left (fun m (id, ctyp) -> Bindings.add id ctyp m) !unifications monomorphic_ctors)
                                                   ctx.variants } in
 
+     let cdefs = List.map (cdef_map_ctyp (map_ctyp (fix_variant_ctyp var_id new_ctors))) cdefs in
      let cdefs, ctx = specialize_variants ctx cdefs in
-     CDEF_type (CTD_variant (var_id, monomorphic_ctors @ Bindings.bindings !unifications)) :: cdefs, ctx
+     CDEF_type (CTD_variant (var_id, new_ctors)) :: cdefs, ctx
 
   | cdef :: cdefs ->
      let remove_poly (I_aux (instr, aux)) =
@@ -2752,30 +2759,45 @@ let codegen_def' ctx = function
      ^^ jump 0 2 (separate_map hardline (codegen_instr (mk_id "let") ctx) cleanup) ^^ hardline
      ^^ string "}"
 
+(** As we generate C we need to generate specialized version of tuple,
+   list, and vector type. These must be generated in the correct
+   order. The ctyp_dependencies function generates a list of
+   c_gen_typs in the order they must be generated. Types may be
+   repeated in ctyp_dependencies so it's up to the code-generator not
+   to repeat definitions pointlessly (using the !generated variable)
+   *)
+type c_gen_typ =
+  | CTG_tup of ctyp list
+  | CTG_list of ctyp
+  | CTG_vector of bool * ctyp
+
+let rec ctyp_dependencies = function
+  | CT_tup ctyps -> List.concat (List.map ctyp_dependencies ctyps) @ [CTG_tup ctyps]
+  | CT_list ctyp -> ctyp_dependencies ctyp @ [CTG_list ctyp]
+  | CT_vector (direction, ctyp) -> ctyp_dependencies ctyp @ [CTG_vector (direction, ctyp)]
+  | CT_ref ctyp -> ctyp_dependencies ctyp
+  | CT_struct (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors)
+  | CT_variant (_, ctors) -> List.concat (List.map (fun (_, ctyp) -> ctyp_dependencies ctyp) ctors)
+  | CT_int | CT_int64 | CT_bits _ | CT_bits64 _ | CT_unit | CT_bool | CT_real | CT_bit | CT_string | CT_enum _ | CT_poly -> []
+
+let codegen_ctg ctx = function
+  | CTG_vector (direction, ctyp) -> codegen_vector ctx (direction, ctyp)
+  | CTG_tup ctyps -> codegen_tup ctx ctyps
+  | CTG_list ctyp -> codegen_list ctx ctyp
+
+(** When we generate code for a definition, we need to first generate
+   any auxillary type definitions that are required. *)
 let codegen_def ctx def =
-  let untup = function
-    | CT_tup ctyps -> ctyps
-    | _ -> assert false
-  in
-  let unlist = function
-    | CT_list ctyp -> ctyp
-    | _ -> assert false
-  in
-  let unvector = function
-    | CT_vector (direction, ctyp) -> (direction, ctyp)
-    | _ -> assert false
-  in
-  let tups = List.filter is_ct_tup (cdef_ctyps ctx def) in
-  let tups = List.map (fun ctyp -> codegen_tup ctx (untup ctyp)) tups in
-  let lists = List.filter is_ct_list (cdef_ctyps ctx def) in
-  let lists = List.map (fun ctyp -> codegen_list ctx (unlist ctyp)) lists in
-  let vectors = List.filter is_ct_vector (cdef_ctyps ctx def) in
-  let vectors = List.map (fun ctyp -> codegen_vector ctx (unvector ctyp)) vectors in
-  (* prerr_endline (Pretty_print_sail.to_string (pp_cdef def)); *)
-  concat vectors
-  ^^ concat lists
-  ^^ concat tups
-  ^^ codegen_def' ctx def
+  let ctyps = cdef_ctyps ctx def in
+  (* We should have erased only polymorphism introduced by variants at this point! *)
+  if List.exists is_polymorphic ctyps then
+    let polymorphic_ctyps = List.filter is_polymorphic ctyps in
+    c_error (Printf.sprintf "Found polymorphic types:\n%s\nwhile generating definition."
+                            (Util.string_of_list "\n" string_of_ctyp polymorphic_ctyps))
+  else
+    let deps = List.concat (List.map ctyp_dependencies ctyps) in
+    separate_map hardline (codegen_ctg ctx) deps
+    ^^ codegen_def' ctx def
 
 let is_cdef_startup = function
   | CDEF_startup _ -> true