Extraction of zero-argument functions (wip)

Bench reestablished

src/mlw/compile.mli

@@ -9,18 +9,10 @@
 (*                                                                  *)
 (********************************************************************)
 
-open Ident
-
 val clean_name : string -> string
 
 val module_name : ?fname:string -> string list -> string -> string
 
-module ML : sig
-  val get_decl_name : Mltree.decl -> ident list
-
-  val iter_deps : (Ident.ident -> unit) -> Mltree.decl -> unit
-end
-
 module Translate : sig
   val module_ : Pmodule.pmodule -> Mltree.pmodule
 

src/mlw/cprinter.ml

@@ -1008,7 +1008,7 @@ module MLToC = struct
   let translate_decl (info:info) (d:Mltree.decl) : C.definition option
     =
     let decide_print id = query_syntax info.syntax id = None in
-    match Compile.ML.get_decl_name d with
+    match Mltree.get_decl_name d with
     | [id] when decide_print id ->
        if debug then Format.printf "print %s@." id.id_string;
        translate_decl info d

src/mlw/mltree.ml

@@ -121,3 +121,232 @@ type pmodule = {
   mod_decl  : decl list;   (* module declarations *)
   mod_known : known_map;   (* known identifiers *)
 }
+
+let rec get_decl_name = function
+  | Dtype itdefl ->
+      let add_id = function (* add name of constructors and projections *)
+        | Some (Ddata l)   -> List.map (fun (idc,    _) -> idc) l
+        | Some (Drecord l) -> List.map (fun (_, idp, _) -> idp) l
+        | _ -> [] in
+      let add_td_ids {its_name = id; its_def = def} = id :: (add_id def) in
+      List.flatten (List.map add_td_ids itdefl)
+  | Dlet (Lrec rdef) -> List.map (fun {rec_sym = rs} -> rs.rs_name) rdef
+  | Dlet (Lvar ({pv_vs={vs_name=id}}, _))
+  | Dlet (Lsym ({rs_name=id}, _, _, _))
+  | Dlet (Lany ({rs_name=id}, _, _))
+  | Dexn ({xs_name=id}, _) -> [id]
+  | Dmodule (_, dl) -> List.concat (List.map get_decl_name dl)
+
+let rec add_known_decl decl k_map id =
+  match decl with
+  | Dmodule (_, dl) ->
+      let add_decl k_map d =
+        let idl = get_decl_name d in
+        List.fold_left (add_known_decl d) k_map idl in
+      List.fold_left add_decl k_map dl
+  | _ -> Mid.add id decl k_map
+
+let rec iter_deps_ty f = function
+  | Tvar _ -> ()
+  | Tapp (id, ty_l) -> f id; List.iter (iter_deps_ty f) ty_l
+  | Ttuple ty_l -> List.iter (iter_deps_ty f) ty_l
+
+let iter_deps_typedef f = function
+  | Ddata constrl ->
+      List.iter (fun (_, tyl) -> List.iter (iter_deps_ty f) tyl) constrl
+  | Drecord pjl -> List.iter (fun (_, _, ty) -> iter_deps_ty f ty) pjl
+  | Dalias ty -> iter_deps_ty f ty
+  | Drange _ | Dfloat _ -> ()
+
+let iter_deps_its_defn f its_d =
+  Opt.iter (iter_deps_typedef f) its_d.its_def
+
+let iter_deps_args f =
+  List.iter (fun (_, ty_arg, _) -> iter_deps_ty f ty_arg)
+
+let rec iter_deps_xbranch f (xs, _, e) =
+  f xs.xs_name;
+  iter_deps_expr f e
+
+and iter_deps_pat_list f patl =
+  List.iter (iter_deps_pat f) patl
+
+and iter_deps_pat f = function
+  | Pwild | Pvar _ -> ()
+  | Papp (ls, patl) ->
+      f ls.ls_name;
+      iter_deps_pat_list f patl
+  | Ptuple patl -> iter_deps_pat_list f patl
+  | Por (p1, p2) ->
+      iter_deps_pat f p1;
+      iter_deps_pat f p2
+  | Pas (p, _) -> iter_deps_pat f p
+
+and iter_deps_expr f e = match e.e_node with
+  | Econst _ | Evar _ | Eabsurd | Ehole -> ()
+  | Eapp (rs, exprl) ->
+      f rs.rs_name; List.iter (iter_deps_expr f) exprl
+  | Efun (args, e) ->
+      List.iter (fun (_, ty_arg, _) -> iter_deps_ty f ty_arg) args;
+      iter_deps_expr f e
+  | Elet (Lvar (_, e1), e2) ->
+      iter_deps_expr f e1;
+      iter_deps_expr f e2
+  | Elet (Lsym (_, ty_result, args, e1), e2) ->
+      iter_deps_ty f ty_result;
+      List.iter (fun (_, ty_arg, _) -> iter_deps_ty f ty_arg) args;
+      iter_deps_expr f e1;
+      iter_deps_expr f e2
+  | Elet (Lany (_, ty_result, args), e2) ->
+      iter_deps_ty f ty_result;
+      List.iter (fun (_, ty_arg, _) -> iter_deps_ty f ty_arg) args;
+      iter_deps_expr f e2
+  | Elet ((Lrec rdef), e) ->
+      List.iter
+        (fun {rec_sym = rs; rec_args = args; rec_exp = e; rec_res = res} ->
+           f rs.rs_name; iter_deps_args f args;
+           iter_deps_expr f e; iter_deps_ty f res) rdef;
+      iter_deps_expr f e
+  | Ematch (e, branchl, xl) ->
+      iter_deps_expr f e;
+      List.iter (fun (p, e) -> iter_deps_pat f p; iter_deps_expr f e) branchl;
+      List.iter (iter_deps_xbranch f) xl
+  | Eif (e1, e2, e3) ->
+      iter_deps_expr f e1;
+      iter_deps_expr f e2;
+      iter_deps_expr f e3
+  | Eblock exprl ->
+      List.iter (iter_deps_expr f) exprl
+  | Ewhile (e1, e2) ->
+      iter_deps_expr f e1;
+      iter_deps_expr f e2
+  | Efor (_, _, _, _, e) ->
+      iter_deps_expr f e
+  | Eraise (xs, None) ->
+      f xs.xs_name
+  | Eraise (xs, Some e) ->
+      f xs.xs_name;
+      iter_deps_expr f e
+  | Eexn (_xs, None, e) -> (* FIXME? How come we never do binding here? *)
+      iter_deps_expr f e
+  | Eexn (_xs, Some ty, e) -> (* FIXME? How come we never do binding here? *)
+      iter_deps_ty f ty;
+      iter_deps_expr f e
+  | Eassign assingl ->
+      List.iter (fun (_, rs, _) -> f rs.rs_name) assingl
+  | Eignore e -> iter_deps_expr f e
+
+let rec iter_deps f = function
+  | Dtype its_dl ->
+      List.iter (iter_deps_its_defn f) its_dl
+  | Dlet (Lsym (_rs, ty_result, args, e)) ->
+      iter_deps_ty f ty_result;
+      iter_deps_args f args;
+      iter_deps_expr f e
+  | Dlet (Lany (_rs, ty_result, args)) ->
+      iter_deps_ty f ty_result;
+      iter_deps_args f args
+  | Dlet (Lrec rdef) ->
+      List.iter
+        (fun {rec_sym = rs; rec_args = args; rec_exp = e; rec_res = res} ->
+           f rs.rs_name; iter_deps_args f args;
+           iter_deps_expr f e; iter_deps_ty f res) rdef
+  | Dlet (Lvar (_, e)) -> iter_deps_expr f e
+  | Dexn (_, None) -> ()
+  | Dexn (_, Some ty) -> iter_deps_ty f ty
+  | Dmodule (_, dl) -> List.iter (iter_deps f) dl
+
+let ity_unit = I Ity.ity_unit
+
+let ity_of_mask ity mask =
+  let mk_ty acc ty = function MaskGhost -> acc | _ -> ty :: acc in
+  match ity, mask with
+  | _, MaskGhost   -> ity_unit
+  | _, MaskVisible -> ity
+  | I ({ity_node = Ityapp ({its_ts = s}, tl, _)}), MaskTuple m
+    when is_ts_tuple s && List.length tl = List.length m ->
+      let tl = List.fold_left2 mk_ty [] tl m in
+      I (ity_tuple tl)
+  | _ -> ity (* FIXME ? *)
+
+let mk_expr e_node e_ity mask e_effect e_label =
+  { e_node; e_ity = ity_of_mask e_ity mask; e_effect; e_label; }
+
+let tunit = Ttuple []
+
+let is_unit = function
+  | I i -> ity_equal i Ity.ity_unit
+  | _ -> false
+
+let enope = Eblock []
+
+let mk_hole =
+  mk_expr Ehole (I Ity.ity_unit) MaskVisible Ity.eff_empty Slab.empty
+
+let mk_var id ty ghost = (id, ty, ghost)
+
+let mk_var_unit =
+  mk_var (id_register (id_fresh "_")) tunit false
+
+let mk_its_defn its_name its_args its_private its_def =
+  { its_name; its_args; its_private; its_def; }
+
+(* smart constructors *)
+let e_unit =
+  mk_expr enope (I Ity.ity_unit) MaskVisible Ity.eff_empty Slab.empty
+
+let var_defn pv e =
+  Lvar (pv, e)
+
+let sym_defn f ty_res args e =
+  Lsym (f, ty_res, args, e)
+
+let e_let ld e = mk_expr (Elet (ld, e))
+
+let e_app rs pvl =
+  mk_expr (Eapp (rs, pvl))
+
+let e_fun args e = mk_expr (Efun (args, e))
+
+let e_ignore e =
+  if is_unit e.e_ity then e
+  else mk_expr (Eignore e) ity_unit MaskVisible e.e_effect e.e_label
+
+let e_if e1 e2 e3 =
+  mk_expr (Eif (e1, e2, e3)) e2.e_ity
+
+let e_while e1 e2 =
+  mk_expr (Ewhile (e1, e2)) ity_unit
+
+let e_for pv1 pv2 dir pv3 e1 =
+  mk_expr (Efor (pv1, pv2, dir, pv3, e1)) ity_unit
+
+let e_match e bl xl =
+  mk_expr (Ematch (e, bl, xl))
+
+(*
+  let e_match_exn e bl eff_bl lbl_match xl =
+    let ity = match bl with (_, d) :: _ -> d.e_ity | [] -> assert false in
+    let e = e_match e bl ity eff_bl lbl_match in
+    mk_expr (Etry (e, true, xl))
+*)
+
+let e_assign al ity mask eff lbl =
+  if al = [] then e_unit else mk_expr (Eassign al) ity mask eff lbl
+
+let e_absurd =
+  mk_expr Eabsurd
+
+let e_seq e1 e2 =
+  let e = match e1.e_node, e2.e_node with
+    | (Eblock [] | Ehole), e | e, (Eblock [] | Ehole) -> e
+    | Eblock e1, Eblock e2 -> Eblock (e1 @ e2)
+    | _, Eblock e2 -> Eblock (e1 :: e2)
+    | Eblock e1, _ -> Eblock (e1 @ [e2])
+    | _ -> Eblock [e1; e2] in
+  mk_expr e
+
+let var_list_of_pv_list pvl =
+  let mk_var pv = mk_expr (Evar pv) (I pv.pv_ity)
+      MaskVisible eff_empty Slab.empty in
+  List.map mk_var pvl

src/mlw/ocaml_printer.ml

@@ -41,7 +41,6 @@ type info = {
 module Print = struct
 
   open Mltree
-  open Compile.ML
 
   (* extraction labels *)
   let optional_arg = create_label "ocaml:optional"

src/tools/why3extract.ml

@@ -146,7 +146,7 @@ let print_preludes =
 let print_mdecls ?fname m mdecls =
   let (fg,pargs,pr) = Pdriver.lookup_printer opt_driver in
   let test_decl_not_driver decl =
-    let decl_name = ML.get_decl_name decl in
+    let decl_name = Mltree.get_decl_name decl in
     let test_id_not_driver id =
       Printer.query_syntax pargs.Pdriver.syntax id = None in
     List.exists test_id_not_driver decl_name in
@@ -292,7 +292,7 @@ let rec visit ~recurs mm id =
   if not (Ident.Hid.mem visited id) then begin try
       let d = find_decl mm id in
       Ident.Hid.add visited id ();
-      if recurs then ML.iter_deps (visit ~recurs mm) d;
+      if recurs then Mltree.iter_deps (visit ~recurs mm) d;
       toextract := { info_rec = recurs; info_id = id } :: !toextract
     with Not_found -> ()
   end

tests/test-extraction/main.ml

@@ -12,7 +12,7 @@ let () = assert (test_int      () = b42)
 let () = assert (test_int63    () = b42)
 let () = assert (test_ref      () = b42)
 let () = assert (test_array63  () = b42)
-let () = assert (test_partial2 ()   = b42)
+let () = assert (test_partial2    = b42)
 let () = main ()
 
 let () = Format.printf "OCaml extraction test successful@."