Commit 8193b6af authored by Mário Pereira's avatar Mário Pereira

Code extraction (wip)

Better treatment of partial applied constructors
parent 96fa3631
...@@ -71,8 +71,8 @@ module mach.int.Int63 ...@@ -71,8 +71,8 @@ module mach.int.Int63
syntax function to_int "Z.of_int %1" syntax function to_int "Z.of_int %1"
syntax type int63 "int" syntax type int63 "int"
syntax constant min_int63 "min_int" syntax constant min_int63 "Z.of_int min_int"
syntax constant max_int63 "max_int" syntax constant max_int63 "Z.of_int max_int"
syntax val ( + ) "%1 + %2" syntax val ( + ) "%1 + %2"
syntax val ( - ) "%1 - %2" syntax val ( - ) "%1 - %2"
syntax val (-_) "- %1" syntax val (-_) "- %1"
......
...@@ -211,18 +211,6 @@ module ML = struct ...@@ -211,18 +211,6 @@ module ML = struct
end end
type decl = ML.decl
type info = {
info_syn : syntax_map;
info_convert : syntax_map;
info_current_th : Theory.theory;
info_current_mo : Pmodule.pmodule option;
info_th_known_map : Decl.known_map;
info_mo_known_map : Pdecl.known_map;
info_fname : string option;
}
(** Translation from Mlw to ML *) (** Translation from Mlw to ML *)
module Translate = struct module Translate = struct
...@@ -231,6 +219,16 @@ module Translate = struct ...@@ -231,6 +219,16 @@ module Translate = struct
open Pmodule open Pmodule
open Pdecl open Pdecl
type info = {
(* info_syn : syntax_map; *)
(* info_convert : syntax_map; *)
(* info_current_th : Theory.theory; *)
info_current_mo : Pmodule.pmodule option;
(* info_th_known_map : Decl.known_map; *)
info_mo_known_map : Pdecl.known_map;
(* info_fname : string option; *)
}
(* useful predicates and transformations *) (* useful predicates and transformations *)
let pv_not_ghost e = not e.pv_ghost let pv_not_ghost e = not e.pv_ghost
...@@ -337,7 +335,7 @@ module Translate = struct ...@@ -337,7 +335,7 @@ module Translate = struct
List.exists is_constructor its List.exists is_constructor its
| _ -> false | _ -> false
let make_eta_expansion rsc pvl cty_app = let mk_eta_expansion rsc pvl cty_app =
(* FIXME : effects and types of the expression in this situation *) (* FIXME : effects and types of the expression in this situation *)
let args_f = let args_f =
let def pv = pv_name pv, ity pv.pv_ity, pv.pv_ghost in let def pv = pv_name pv, ity pv.pv_ity, pv.pv_ghost in
...@@ -452,9 +450,12 @@ module Translate = struct ...@@ -452,9 +450,12 @@ module Translate = struct
ML.mk_expr ml_letrec (ML.I e.e_ity) eff ML.mk_expr ml_letrec (ML.I e.e_ity) eff
| Elet (LDsym (rsf, {c_node = Capp (rs_app, pvl); c_cty = cty}), ein) | Elet (LDsym (rsf, {c_node = Capp (rs_app, pvl); c_cty = cty}), ein)
when isconstructor info rs_app -> when isconstructor info rs_app ->
let eta_app = make_eta_expansion rs_app pvl cty in (* partial application of constructor *)
let eta_app = mk_eta_expansion rs_app pvl cty in
let ein = expr info ein in let ein = expr info ein in
let res = ity cty.cty_result in let mk_func pv f = ity_func pv.pv_ity f in
let func = List.fold_right mk_func cty.cty_args cty.cty_result in
let res = ity func in
let ml_letrec = ML.Elet (ML.Lsym (rsf, res, [], eta_app), ein) in let ml_letrec = ML.Elet (ML.Lsym (rsf, res, [], eta_app), ein) in
ML.mk_expr ml_letrec (ML.I e.e_ity) e.e_effect ML.mk_expr ml_letrec (ML.I e.e_ity) e.e_effect
| Elet (LDsym (rsf, {c_node = Capp (rs_app, pvl); c_cty = cty}), ein) -> | Elet (LDsym (rsf, {c_node = Capp (rs_app, pvl); c_cty = cty}), ein) ->
...@@ -486,6 +487,9 @@ module Translate = struct ...@@ -486,6 +487,9 @@ module Translate = struct
ML.mk_unit ML.mk_unit
| Eexec ({c_node = Capp (rs, _)}, _) when rs_ghost rs -> | Eexec ({c_node = Capp (rs, _)}, _) when rs_ghost rs ->
ML.mk_unit ML.mk_unit
| Eexec ({c_node = Capp (rs, pvl); c_cty = cty}, _)
when isconstructor info rs ->
mk_eta_expansion rs pvl cty
| Eexec ({c_node = Capp (rs, pvl); _}, _) -> | Eexec ({c_node = Capp (rs, pvl); _}, _) ->
let pvl = app pvl in let pvl = app pvl in
ML.mk_expr (ML.Eapp (rs, pvl)) (ML.I e.e_ity) eff ML.mk_expr (ML.Eapp (rs, pvl)) (ML.I e.e_ity) eff
......
...@@ -25,6 +25,16 @@ open Stdlib ...@@ -25,6 +25,16 @@ open Stdlib
open Pdecl open Pdecl
open Printer open Printer
type info = {
info_syn : syntax_map;
info_convert : syntax_map;
info_current_th : Theory.theory;
info_current_mo : Pmodule.pmodule option;
info_th_known_map : Decl.known_map;
info_mo_known_map : Pdecl.known_map;
info_fname : string option;
}
module Print = struct module Print = struct
open ML open ML
...@@ -448,10 +458,8 @@ module Print = struct ...@@ -448,10 +458,8 @@ module Print = struct
print_ident xs.xs_name (print_ty ~paren:true info) t print_ident xs.xs_name (print_ty ~paren:true info) t
end end
let extract_module pargs ?old ?fname ({mod_theory = th} as m) fmt d = let print_decl pargs ?old ?fname ({mod_theory = th} as m) fmt d =
ignore (pargs);
ignore (old); ignore (old);
ignore (m);
let info = { let info = {
info_syn = pargs.Pdriver.syntax; info_syn = pargs.Pdriver.syntax;
info_convert = pargs.Pdriver.converter; info_convert = pargs.Pdriver.converter;
...@@ -470,7 +478,7 @@ let fg ?fname m = ...@@ -470,7 +478,7 @@ let fg ?fname m =
(module_name ?fname path mod_name) ^ ".ml" (module_name ?fname path mod_name) ^ ".ml"
let () = Pdriver.register_printer "ocaml" let () = Pdriver.register_printer "ocaml"
~desc:"printer for OCaml code" fg extract_module ~desc:"printer for OCaml code" fg print_decl
(* (*
* Local Variables: * Local Variables:
......
...@@ -222,7 +222,7 @@ type filename_generator = ?fname:string -> Pmodule.pmodule -> string ...@@ -222,7 +222,7 @@ type filename_generator = ?fname:string -> Pmodule.pmodule -> string
type printer = type printer =
printer_args -> ?old:in_channel -> ?fname:string -> Pmodule.pmodule -> printer_args -> ?old:in_channel -> ?fname:string -> Pmodule.pmodule ->
Compile.decl Pp.pp Compile.ML.decl Pp.pp
type reg_printer = Pp.formatted * filename_generator * printer type reg_printer = Pp.formatted * filename_generator * printer
......
...@@ -39,7 +39,7 @@ val load_driver : Env.env -> string -> string list -> driver ...@@ -39,7 +39,7 @@ val load_driver : Env.env -> string -> string list -> driver
type printer = type printer =
printer_args -> ?old:in_channel -> ?fname:string -> Pmodule.pmodule -> printer_args -> ?old:in_channel -> ?fname:string -> Pmodule.pmodule ->
Compile.decl Pp.pp Compile.ML.decl Pp.pp
type filename_generator = ?fname:string -> Pmodule.pmodule -> string type filename_generator = ?fname:string -> Pmodule.pmodule -> string
......
...@@ -119,16 +119,16 @@ let opt_driver = ...@@ -119,16 +119,16 @@ let opt_driver =
eprintf "%a@." Exn_printer.exn_printer e; eprintf "%a@." Exn_printer.exn_printer e;
exit 1 exit 1
let extract_to ?fname ({mod_theory = th} as m) = let extract_to ?fname m =
let (fg,pargs,pr) = Pdriver.lookup_printer opt_driver in let (fg,pargs,pr) = Pdriver.lookup_printer opt_driver in
let info = { let info = {
info_syn = pargs.Pdriver.syntax; (* info_syn = pargs.Pdriver.syntax; *)
info_convert = pargs.Pdriver.converter; (* info_convert = pargs.Pdriver.converter; *)
info_current_th = th; (* info_current_th = th; *)
info_current_mo = Some m; Translate.info_current_mo = Some m;
info_th_known_map = th.Theory.th_known; (* info_th_known_map = th.Theory.th_known; *)
info_mo_known_map = m.mod_known; Translate.info_mo_known_map = m.mod_known;
info_fname = Opt.map Compile.clean_name fname (* info_fname = Opt.map Compile.clean_name fname *)
} in } in
let mdecls = Translate.module_ info m in let mdecls = Translate.module_ info m in
let mdecls = Transform.module_ info mdecls in let mdecls = Transform.module_ info mdecls in
...@@ -147,8 +147,7 @@ let extract_to ?fname ({mod_theory = th} as m) = ...@@ -147,8 +147,7 @@ let extract_to ?fname ({mod_theory = th} as m) =
Debug.dprintf Pdriver.debug "extract module %s to file %s@." tname file; Debug.dprintf Pdriver.debug "extract module %s to file %s@." tname file;
List.iter (pr ?old ?fname pargs m fmt) mdecls; List.iter (pr ?old ?fname pargs m fmt) mdecls;
close_out cout close_out cout
| Monolithic -> | Monolithic -> ()
()
let extract_to = let extract_to =
let visited = Ident.Hid.create 17 in let visited = Ident.Hid.create 17 in
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment